aboutsummaryrefslogtreecommitdiff
path: root/whispers
diff options
context:
space:
mode:
authorRunciter2024-10-28 02:19:54 +0800
committerRunciter2024-10-28 02:19:54 +0800
commitaf5bbe630cb990daf9f29b307572f965ee9fa099 (patch)
tree86baaba3b27b4eec62cb8ec40692812854901a3f /whispers
downloadwhispers-af5bbe630cb990daf9f29b307572f965ee9fa099.tar.gz
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
Diffstat (limited to 'whispers')
-rw-r--r--whispers/packages/dict.scm260
-rw-r--r--whispers/packages/doc.scm80
-rw-r--r--whispers/packages/pdf.scm158
-rw-r--r--whispers/packages/sh.scm98
-rw-r--r--whispers/packages/whispers.scm119
-rw-r--r--whispers/services/console.scm89
-rw-r--r--whispers/services/dict.scm146
-rw-r--r--whispers/services/finance.scm283
-rw-r--r--whispers/services/gps.scm102
-rw-r--r--whispers/services/proton.scm117
-rw-r--r--whispers/services/ssh-agent.scm153
-rw-r--r--whispers/services/ssh-tunneler.scm904
-rw-r--r--whispers/services/whispers.scm792
-rw-r--r--whispers/services/whispers/finance.scm331
-rw-r--r--whispers/services/whispers/gps.scm100
-rw-r--r--whispers/services/whispers/mail.scm174
-rw-r--r--whispers/services/whispers/ssh.scm629
-rw-r--r--whispers/services/whispers/vpn.scm3424
-rw-r--r--whispers/services/whispers/xdg.scm81
-rw-r--r--whispers/tests/ssh-tunneler.scm107
20 files changed, 8147 insertions, 0 deletions
diff --git a/whispers/packages/dict.scm b/whispers/packages/dict.scm
new file mode 100644
index 0000000..f80f912
--- /dev/null
+++ b/whispers/packages/dict.scm
@@ -0,0 +1,260 @@
+;;; Whispers --- Stealth VPN and ssh tunneler
+;;; Copyright © 2024 Runciter <runciter@whispers-vpn.org>
+;;;
+;;; This file is part of Whispers.
+;;;
+;;; Whispers 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.
+;;;
+;;; Whispers 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 Whispers. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (whispers packages dict)
+ #:use-module (guix)
+ #:use-module (guix build-system gnu)
+ #:use-module ((guix licenses) #:select (gpl2+
+ gpl3+
+ cc-by-sa3.0))
+ #:use-module (guix git-download)
+ #:use-module (guix git)
+ #:use-module (gnu packages autotools)
+ #:use-module (gnu packages gawk)
+ #:use-module (gnu packages bison)
+ #:use-module (gnu packages flex)
+ #:use-module (gnu packages base)
+ #:use-module (gnu packages compression)
+ #:use-module (gnu packages speech)
+ #:use-module (gnu packages python)
+ #:use-module (gnu packages perl)
+ #:use-module (gnu packages xml)
+ #:export ())
+
+(define-public libmaa-1.3.2
+ (package
+ (name "libmaa")
+ (version "1.3.2")
+ (source (origin
+ (method url-fetch)
+ (uri (string-append "mirror://sourceforge/dict/libmaa/"
+ "libmaa-"
+ version
+ "/libmaa-"
+ version
+ ".tar.gz"))
+ (sha256
+ (base32
+ "1idi4c30pi79g5qfl7rr9s17krbjbg93bi8f2qrbsdlh78ga19ar"))))
+ (inputs (list libtool))
+ (arguments
+ (list #:make-flags
+ #~'("CFLAGS=-DHAVE_CONFIG_H -Wall -Wno-error -g -O2 $(VERCFLAGS) -I. -I${srcdir}")
+ #:test-target "test"))
+ (build-system gnu-build-system)
+ (synopsis "When Khepera rose up out of the watery abyss of Nu, he
+ created Maa as a foundation upon which to create everything else")
+ (description "The libmaa library provides many low-level
+data structures which are helpful for writing compilers, including hash
+tables, sets, lists, debugging support, and memory management. Although
+libmaa was designed and implemented as a foundation for the Khepara
+transformation system, the data structures are generally applicable to a
+wide range of programming problems.
+
+ The memory management routines are especially helpful for improving
+the performance of memory-intensive applications.")
+ (home-page "https://sourceforge.net/projects/dict/")
+ (license gpl2+)))
+
+(define-public dictd-1.13.1
+ (package
+ (name "dictd")
+ (version "1.13.1")
+ (source (origin
+ (method url-fetch)
+ (uri (string-append "mirror://sourceforge/dict/dictd/"
+ "dictd-"
+ version
+ "/dictd-"
+ version
+ ".tar.gz"))
+ (sha256
+ (base32
+ "06racmv25ihwgwf67fgj2703ik0m5i2cjzcxasa88kc92rysdwg4"))))
+ (inputs (list libmaa-1.3.2 zlib libtool bison flex))
+ (arguments
+ (list #:test-target "test"))
+ (build-system gnu-build-system)
+ (synopsis "@command{dict}, @command{dictd} and @command{dictfmt} programs")
+ (description "The DICT Interchange Format (DICF) is a human-readable
+ format for the interchange of dictionary databases for the use with
+DICT protocol client/server software.
+
+This package provides a client @command{dict} and a server program
+@command{dictd} for the DICT protocol, as well as a utility
+@command{dictfmt} to convert various dictionary formats into
+dictionaries that can be served by @command{dictd} or @command{dicos}")
+ (home-page "https://sourceforge.net/projects/dict/")
+ (license gpl2+)))
+
+(define-public freedict-tools-0.6.0
+ (package
+ (name "freedict-tools")
+ (version "0.6.0")
+ (source
+ (origin
+ (method git-fetch)
+ (uri (git-reference
+ (url "https://github.com/freedict/tools")
+ (commit "3596640e6e0582cc5fb76a342e5d8e7413aa4b34")))
+ (sha256
+ (base32 "1raayynvn1j8x0ck8pnbbljl6zxnsyzzil7y54xz03dpj7k9w7mk"))))
+ (inputs (list espeak-ng
+ python perl
+ gzip
+ tar
+ libxslt
+ dictd-1.13.1
+ perl-libxml))
+ (arguments
+ (list #:tests? #f
+ #:phases
+ #~(modify-phases
+ %standard-phases
+ (delete 'configure)
+ (add-before 'build 'set-prefix-in-makefile
+ (lambda* (#:key inputs #:allow-other-keys)
+ (substitute*
+ "Makefile"
+ (("PREFIX \\?=.*")
+ (string-append "PREFIX = "
+ #$output
+ "\n")))
+ (substitute*
+ "mk/dicts.mk"
+ (("available_platforms := src dictd slob")
+ "available_platforms := dictd")))))))
+ (build-system gnu-build-system)
+ (synopsis "The FreeDict tools are used to import, export (build) and
+ manage FreeDict dictionaries")
+ (description "FreeDict is a project that offers over 140 free
+ dictionaries in about 45 languages, with the right to study, change and
+ modify them. You can use them offline on your computer or mobile phone
+ and export them to any format and application.
+
+In order to limit store size and build complexity, only the build
+targets that build dictionaries in dictd format are retained when this
+Guix package is installed.")
+ (home-page "https://freedict.org")
+ (license gpl2+)))
+
+(define-public freedict-dictionaries
+ (package
+ (name "freedict-dictionaries")
+ (version "914b5f7")
+ (source
+ (origin
+ (method git-fetch)
+ (uri (git-reference
+ (url "https://github.com/freedict/fd-dictionaries")
+ (commit "914b5f754b695e9422bf951837b0682a077e244e")))
+ (sha256
+ (base32 "0a8k5rq94rl1nmz0354sx2gmyqica0yjavirh5v5wdybkfq8nv83"))))
+ (inputs (list espeak-ng
+ python perl
+ gzip
+ tar
+ libxslt
+ dictd-1.13.1
+ perl-libxml
+ freedict-tools-0.6.0))
+ (arguments
+ (list #:tests? #f
+ #:make-flags
+ #~(list (string-append "PREFIX="
+ #$output))
+ #:phases
+ #~(modify-phases
+ %standard-phases
+ (delete 'configure)
+ (add-before 'build 'set-tools-prefix-in-makefile
+ (lambda* (#:key inputs #:allow-other-keys)
+ (substitute*
+ "Makefile"
+ (("FREEDICT_TOOLS \\?= ../tools")
+ (string-append "export FREEDICT_TOOLS = "
+ #$(file-append
+ freedict-tools-0.6.0
+ "/share/freedict")))))))))
+ (build-system gnu-build-system)
+ (synopsis "Multilingual dictionaries of the Freedict project,
+ compiled to the dictd format.")
+ (description "FreeDict is a project that offers over 140 free
+ dictionaries in about 45 languages, with the right to study, change and
+ modify them. You can use them offline on your computer or mobile phone
+ and export them to any format and application.
+
+This Guix package only installs the output dictionnaires in dictd
+format.")
+ (home-page "https://freedict.org")
+ (license gpl2+)))
+
+(define-public cc-cedict
+ (package
+ (name "cc-cedict")
+ (version "0.1")
+ (source
+ (origin
+ (method git-fetch)
+ (uri (git-reference
+ (url "https://git.whispers-vpn.org/cc-cedict.git")
+ (commit "1bb276d2340eff428ff397dbd493646d880388c4")))
+ (sha256
+ (base32 "1d0l6g83n964af81bl96c9hbd6gacbq9a68n5d9wgifihl33z4q7"))))
+ (inputs (list sed
+ gawk
+ gzip
+ dictd-1.13.1))
+ (arguments (list #:tests? #f))
+ (build-system gnu-build-system)
+ (synopsis "CC-CEDICT is a community-maintained free Chinese-English
+ dictionary.")
+ (description "CC-CEDICT is a community-maintained free
+ Chinese-English dictionary. It is a continuation of the CEDICT project
+started by Paul Denisowski in 1997 with the aim to provide a complete
+downloadable Chinese to English dictionary with pronunciation in pinyin
+for the Chinese characters.
+
+CC-CEDICT is licensed under a Creative Commons license CC-BY-SA.
+
+Published by MDBG
+
+License: Creative Commons Attribution-Share Alike 3.0
+
+Referenced works: CEDICT - Copyright © 1997, 1998 Paul Andrew Denisowski
+
+CC-CEDICT can be downloaded from:
+http://www.mdbg.net/chindict/chindict.php?page=cc-cedict
+
+Additions and corrections to the CC-CEDICT source can be sent through:
+http://cc-cedict.org/editor/editor.php
+
+For more information about CC-CEDICT see:
+http://cc-cedict.org/wiki/
+
+This package converts the community maintained text file containing the
+CC-CEDICT dictionary into 5 dictionaries in the DICT Interchange format,
+which can be served to client programs such as 'dico' and 'dicod' by
+servers implementing the DICT protocol (RFC 2229), such as 'dictd' or
+'dicod'.
+
+While the exporter script that this package uses to create the
+dictionaries is licensed under the GPL, the output dictionaries are
+licensed under CC-BY-SA version 3.0.")
+ (home-page "http://cc-cedict.org/")
+ (license (list cc-by-sa3.0 gpl3+))))
diff --git a/whispers/packages/doc.scm b/whispers/packages/doc.scm
new file mode 100644
index 0000000..354d983
--- /dev/null
+++ b/whispers/packages/doc.scm
@@ -0,0 +1,80 @@
+;;; Whispers --- Stealth VPN and ssh tunneler
+;;; Copyright © 2024 Runciter <runciter@whispers-vpn.org>
+;;;
+;;; This file is part of Whispers.
+;;;
+;;; Whispers 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.
+;;;
+;;; Whispers 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 Whispers. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (whispers packages doc)
+ #:use-module (gnu)
+ #:use-module (gnu packages)
+ #:use-module (gnu packages autotools)
+ #:use-module (gnu packages gettext)
+ #:use-module (gnu packages texinfo)
+ #:use-module (gnu packages man)
+ #:use-module (gnu packages base)
+ #:use-module (gnu packages admin)
+ #:use-module (gnu packages pkg-config)
+ #:use-module (guix packages)
+ #:use-module (guix build-system gnu)
+ #:use-module (guix download)
+ #:use-module (guix git-download)
+ #:use-module (guix git)
+ #:use-module ((guix licenses) #:prefix license:)
+ #:export ())
+
+(define-public ssh-tunneler-doc
+ (package
+ (name "ssh-tunneler-doc")
+ (version "0.1")
+ (source
+ (origin
+ (method git-fetch)
+ (uri (git-reference
+ (url "https://git.whispers-vpn.org/ssh-tunneler-doc.git")
+ (commit "0b1d8a50339adb15c5915cec5e01102684cd571c")))
+ (sha256
+ (base32 "1vv1bwz99aafmwb8vhkh3rxqncyskk715hm1irya8dpvfkk0c5r3"))))
+ (native-inputs (list autoconf automake pkg-config texinfo))
+ (inputs (list))
+ (arguments (list #:tests? #f))
+ (build-system gnu-build-system)
+ (synopsis "Documentation for ssh tunneler Guix services.")
+ (description "Documentation for ssh tunneler Guix services. This
+package provides an info manual.")
+ (home-page "https://git.whispers-vpn.org/ssh-tunneler-doc.git")
+ (license (list license:fdl1.3+))))
+
+(define-public whispers-doc
+ (package
+ (name "whispers-doc")
+ (version "0.1")
+ (source
+ (origin
+ (method git-fetch)
+ (uri (git-reference
+ (url "https://git.whispers-vpn.org/whispers-doc.git")
+ (commit "2a76cd88aa9f2ee182ec059870fde832bf182d33")))
+ (sha256
+ (base32 "1h7lc110qhd8slgzjv6ap91r17grcflpgkp3bpxvng0dj55dmk2a"))))
+ (native-inputs (list autoconf automake pkg-config texinfo))
+ (inputs (list))
+ (propagated-inputs (list ssh-tunneler-doc))
+ (arguments (list #:tests? #f))
+ (build-system gnu-build-system)
+ (synopsis "Documentation for whispers Guix services.")
+ (description "Documentation for whispers Guix services. This package
+provides info manuals.")
+ (home-page "https://git.whispers-vpn.org/whispers-doc.git")
+ (license (list license:fdl1.3+))))
diff --git a/whispers/packages/pdf.scm b/whispers/packages/pdf.scm
new file mode 100644
index 0000000..00c6485
--- /dev/null
+++ b/whispers/packages/pdf.scm
@@ -0,0 +1,158 @@
+;;; Whispers --- Stealth VPN and ssh tunneler
+;;; Copyright © 2013, 2015, 2016 Andreas Enge <andreas@enge.fr>
+;;; Copyright © 2014 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2014, 2015, 2016, 2018, 2019, 2021, 2024 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2015 Paul van der Walt <paul@denknerd.org>
+;;; Copyright © 2016 Roel Janssen <roel@gnu.org>
+;;; Copyright © 2016 Nikita <nikita@n0.is>
+;;; Copyright © 2016-2020, 2022, 2023 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2016, 2017, 2022 Marius Bakke <marius@gnu.org>
+;;; Copyright © 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016 Julien Lepiller <julien@lepiller.eu>
+;;; Copyright © 2016, 2019 Arun Isaac <arunisaac@systemreboot.net>
+;;; Copyright © 2017, 2018 Leo Famulari <leo@famulari.name>
+;;; Copyright © 2017 Alex Vong <alexvong1995@gmail.com>
+;;; Copyright © 2017, 2018 Rene Saavedra <pacoon@protonmail.com>
+;;; Copyright © 2017–2022 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2019 Alex Griffin <a@ajgrf.com>
+;;; Copyright © 2019 Ben Sturmfels <ben@sturm.com.au>
+;;; Copyright © 2019,2020 Hartmut Goebel <h.goebel@crazy-compilers.com>
+;;; Copyright © 2020-2024 Nicolas Goaziou <mail@nicolasgoaziou.fr>
+;;; Copyright © 2020, 2022 Michael Rohleder <mike@rohleder.de>
+;;; Copyright © 2020, 2024 Timotej Lazar <timotej.lazar@araneo.si>
+;;; Copyright © 2020, 2022, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
+;;; Copyright © 2022 Paul A. Patience <paul@apatience.com>
+;;; Copyright © 2022 Petr Hodina <phodina@protonmail.com>
+;;; Copyright © 2023 Felix Gruber <felgru@posteo.net>
+;;; Copyright © 2024 dan <i@dan.games>
+;;; Copyright © 2023 Benjamin Slade <slade@lambda-y.net>
+;;;
+;;; Copyright © 2024 Runciter <runciter@whispers-vpn.org>
+;;;
+;;; This file is part of Whispers.
+;;;
+;;; Whispers 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.
+;;;
+;;; Whispers 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 Whispers. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (whispers packages pdf)
+ #:use-module ((guix licenses) #:prefix license:)
+ #:use-module (guix packages)
+ #:use-module (guix download)
+ #:use-module (guix gexp)
+ #:use-module (guix utils)
+ #:use-module (guix build-system meson)
+ #:use-module (gnu packages)
+ #:use-module (gnu packages pdf)
+ #:use-module (gnu packages ghostscript)
+ #:use-module (gnu packages djvu)
+ #:use-module (gnu packages tls)
+ #:use-module (gnu packages sphinx)
+ #:use-module (gnu packages javascript)
+ #:use-module (gnu packages autotools)
+ #:use-module (gnu packages gettext)
+ #:use-module (gnu packages pkg-config)
+ #:use-module (gnu packages glib)
+ #:use-module (gnu packages check)
+ #:use-module (gnu packages web)
+ #:use-module (gnu packages xorg)
+ #:use-module (gnu packages gtk)
+ #:use-module (gnu packages gnome)
+ #:use-module (gnu packages ocr)
+ #:use-module (gnu packages image)
+ #:use-module (gnu packages sqlite)
+ #:use-module (gnu packages backup)
+ #:use-module (gnu packages tex))
+
+(define-public zathura-synctex
+ (package
+ (inherit zathura)
+ (name "zathura-synctex")
+ (arguments
+ (list
+ #:configure-flags
+ #~(list "-Dsynctex=enabled")
+ #:phases
+ #~(modify-phases %standard-phases
+ (add-before 'check 'start-xserver
+ ;; Tests require a running X server.
+ (lambda* (#:key inputs #:allow-other-keys)
+ (let ((display ":1"))
+ (setenv "DISPLAY" display)
+
+ ;; On busy machines, tests may take longer than
+ ;; the default of four seconds.
+ (setenv "CK_DEFAULT_TIMEOUT" "20")
+
+ ;; Don't fail due to missing '/etc/machine-id'.
+ (setenv "DBUS_FATAL_WARNINGS" "0")
+ (zero? (system (string-append
+ (search-input-file inputs "/bin/Xvfb")
+ " " display " &")))))))))
+ (native-inputs
+ (list pkg-config
+ gettext-minimal
+ (list glib "bin")
+
+ ;; For building documentation.
+ python-sphinx
+
+ ;; For building icons.
+ (librsvg-for-system)
+
+ ;; For tests.
+ check
+ xorg-server-for-tests
+
+ ;; For synctex.
+ texlive-bin))))
+
+(define-public zathura-cb-synctex
+ (package
+ (inherit zathura-cb)
+ (name "zathura-cb-synctex")
+ (inputs (list libarchive zathura-synctex))))
+
+(define-public zathura-ps-synctex
+ (package
+ (inherit zathura-ps)
+ (name "zathura-ps-synctex")
+ (inputs (list libspectre zathura-synctex))))
+
+(define-public zathura-djvu-synctex
+ (package
+ (inherit zathura-djvu)
+ (name "zathura-djvu-synctex")
+ (inputs
+ (list djvulibre zathura-synctex))))
+
+(define-public zathura-pdf-mupdf-synctex
+ (package
+ (inherit zathura-pdf-mupdf)
+ (inputs
+ (list gumbo-parser
+ jbig2dec
+ libjpeg-turbo
+ mujs
+ mupdf
+ openjpeg
+ openssl
+ tesseract-ocr
+ zathura-synctex))))
+
+(define-public zathura-pdf-poppler-synctex
+ (package
+ (inherit zathura-pdf-poppler)
+ (name "zathura-pdf-poppler-synctex")
+ (inputs
+ (list poppler zathura-synctex))))
diff --git a/whispers/packages/sh.scm b/whispers/packages/sh.scm
new file mode 100644
index 0000000..cd9d0a1
--- /dev/null
+++ b/whispers/packages/sh.scm
@@ -0,0 +1,98 @@
+;;; Whispers --- Stealth VPN and ssh tunneler
+;;; Copyright © 2023 Runciter <runciter@whispers-vpn.org>
+;;;
+;;; This file is part of Whispers.
+;;;
+;;; Whispers 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.
+;;;
+;;; Whispers 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 Whispers. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (whispers packages sh)
+ #:use-module (gnu)
+ #:use-module (gnu packages)
+ #:use-module (gnu packages base)
+ #:use-module (gnu packages package-management)
+ #:use-module (whispers packages whispers)
+ #:use-module (guix packages)
+ #:use-module (guix build-system gnu)
+ #:use-module (guix git-download)
+ #:use-module (guix git)
+ #:use-module (guix licenses)
+ #:export ())
+
+(define-public ssh-tunneler-tests
+ (let ((commit "7aa78806ae0385a217164710728632d80a1db932")
+ (chksum "1gyz92xm6wmv2slq9fz1ny1wbmkv6yqpm7ccksqzbfbvhw3nkwcw"))
+ (package
+ (name "ssh-tunneler-tests")
+ (version "0.1")
+ (source
+ (origin
+ (method git-fetch)
+ (uri (git-reference
+ (url "https://git.whispers-vpn.org/ssh-tunneler-tests.git")
+ (commit commit)))
+ (sha256 (base32 chksum))))
+ (build-system gnu-build-system)
+ (home-page "https://git.whispers-vpn.org/ssh-tunneler-tests.git")
+ (synopsis "Test script for the (whispers services ssh-tunneler)
+module.")
+ (description "This package provides the test script of the SSH
+Tunneler Guix services. The script instanciates virtual machines that
+establish persistent ssh connections between themselves.")
+ (license gpl3+))))
+
+(define-public whispers-tests
+ (let ((commit "8ea9f61a000556197f631253ce6193316bde1f61")
+ (chksum "1l87cjiz9c7v9imjzqk29v49yxg3hl58qv8m0m4jdijvlswzrrhp"))
+ (package
+ (name "whispers-tests")
+ (version "0.1")
+ (source
+ (origin
+ (method git-fetch)
+ (uri (git-reference
+ (url "https://git.whispers-vpn.org/whispers-tests.git")
+ (commit commit)))
+ (sha256 (base32 chksum))))
+ (build-system gnu-build-system)
+ (home-page "https://git.whispers-vpn.org/ssh-tunneler-tests.git")
+ (synopsis "Test script for the (whispers services whispers)
+ and (whispers services whispers vpn) modules.")
+ (description "This package provides:
+* A test script instantiating a VM extending a manually configured
+whispers tree, for purposed of testing service status of a bare-bones
+tree of whispers lieutenants.
+* A test script instanciating a VPN network of VMs, for various
+testing puposes.")
+ (license gpl3+))))
+
+(define-public sh-pulse
+ (let ((commit "f2cb88d5cccf05ceeea0003d3250d5c5ce015b9b")
+ (chksum "1yq5lpvz9azap6dp47kcmzf42xypwc3bwsr9cfmjdq01j1pd8gbz"))
+ (package
+ (name "sh-pulse")
+ (version "0.1")
+ (source
+ (origin
+ (method git-fetch)
+ (uri (git-reference
+ (url "https://git.whispers-vpn.org/sh-pulse.git")
+ (commit commit)))
+ (sha256 (base32 chksum))))
+ (build-system gnu-build-system)
+ (home-page "https://git.whispers-vpn.org/sh-pulse.git")
+ (synopsis "Control script for pulseaudio volume and output sink")
+ (description "The vlm script helps the user to easily set keyboard
+shortcuts to control pulseaudio volume, mute and switch pulseaudio
+output.")
+ (license gpl3+))))
diff --git a/whispers/packages/whispers.scm b/whispers/packages/whispers.scm
new file mode 100644
index 0000000..2618635
--- /dev/null
+++ b/whispers/packages/whispers.scm
@@ -0,0 +1,119 @@
+;;; Whispers --- Stealth VPN and ssh tunneler
+;;; Copyright © 2023 Runciter <runciter@whispers-vpn.org>
+;;;
+;;; This file is part of Whispers.
+;;;
+;;; Whispers 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.
+;;;
+;;; Whispers 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 Whispers. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (whispers packages whispers)
+ #:use-module (gnu)
+ #:use-module (gnu packages package-management)
+ #:use-module (gnu packages autotools)
+ #:use-module (gnu packages gettext)
+ #:use-module (gnu packages texinfo)
+ #:use-module (gnu packages man)
+ #:use-module (gnu packages base)
+ #:use-module (gnu packages admin)
+ #:use-module (gnu packages guile)
+ #:use-module (gnu packages guile-xyz)
+ #:use-module (gnu packages pkg-config)
+ #:use-module (guix packages)
+ #:use-module (guix build-system gnu)
+ #:use-module (guix build-system guile)
+ #:use-module (guix download)
+ #:use-module (guix git-download)
+ #:use-module (guix git)
+ #:use-module ((guix licenses) #:prefix license:)
+ #:export ())
+
+(define-public whispers
+ (let ((commit "2b583171c9480e129d0349d1cf9a580a9c8b19e6")
+ (chksum "13p02hdfnmkf5wr2d6acpcfix03crsn68wkvm73cmy0ibndjvczk"))
+ (package
+ (name "whispers")
+ (version "0.1")
+ (source
+ (origin
+ (method git-fetch)
+ (uri (git-reference
+ (url "https://git.whispers-vpn.org/whispers-command.git")
+ (commit commit)))
+ (sha256 (base32 chksum))))
+ (build-system gnu-build-system)
+ (arguments
+ `(#:modules
+ ((ice-9 match)
+ (ice-9 ftw)
+ ,@%gnu-build-system-modules)
+ #:phases
+ (modify-phases
+ %standard-phases
+ (add-after
+ 'install
+ 'hall-wrap-binaries
+ (lambda* (#:key inputs outputs #:allow-other-keys)
+ (let* ((compiled-dir
+ (lambda (out version)
+ (string-append
+ out
+ "/lib/guile/"
+ version
+ "/site-ccache")))
+ (uncompiled-dir
+ (lambda (out version)
+ (string-append
+ out
+ "/share/guile/site"
+ (if (string-null? version) "" "/")
+ version)))
+ (dep-path
+ (lambda (env modules path)
+ (list env
+ ":"
+ 'prefix
+ (cons modules
+ (map (lambda (input)
+ (string-append
+ (assoc-ref inputs input)
+ path))
+ ,''("guile-config"))))))
+ (out (assoc-ref outputs "out"))
+ (bin (string-append out "/bin/"))
+ (site (uncompiled-dir out "")))
+ (match (scandir site)
+ (("." ".." version)
+ (for-each
+ (lambda (file)
+ (wrap-program
+ (string-append bin file)
+ (dep-path
+ "GUILE_LOAD_PATH"
+ (uncompiled-dir out version)
+ (uncompiled-dir "" version))
+ (dep-path
+ "GUILE_LOAD_COMPILED_PATH"
+ (compiled-dir out version)
+ (compiled-dir "" version))))
+ ,''("whispers"))
+ #t))))))))
+ (native-inputs
+ (list autoconf automake pkg-config texinfo))
+ (inputs (list guile-3.0))
+ (propagated-inputs (list guile-config))
+ (synopsis
+ "Perform actions of the services of the shepherd daemons of\na whispers tree.")
+ (description
+ "The whispers command is a simple convenience wrapper\n around the herd program. Instead of specifying a file path\nto the listening socket of a running shepherd in the whispers tree, the\nuser simply provides its absolute whispers tree path as an\nargument to the --lieutenant option of this command.")
+ (home-page "https://git.whispers-vpn.org/whispers-command.git")
+ (license license:gpl3+))))
diff --git a/whispers/services/console.scm b/whispers/services/console.scm
new file mode 100644
index 0000000..bb72a22
--- /dev/null
+++ b/whispers/services/console.scm
@@ -0,0 +1,89 @@
+;;; Whispers --- Stealth VPN and ssh tunneler
+;;; Copyright © 2024 Runciter <runciter@whispers-vpn.org>
+;;;
+;;; This file is part of Whispers.
+;;;
+;;; Whispers 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.
+;;;
+;;; Whispers 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 Whispers. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (whispers services console)
+ #:use-module (guix gexp)
+ #:use-module (guix records)
+ #:use-module (gnu services)
+ #:use-module (gnu services shepherd)
+ #:use-module (gnu packages linux)
+ #:export (console-blank-configuration
+ console-blank-configuration?
+ make-console-blank-configuration
+ this-console-blank-configuration
+ console-blank-service-type))
+
+(define-record-type* <console-blank-configuration>
+ console-blank-configuration make-console-blank-configuration
+ console-blank-configuration?
+ this-console-blank-configuration
+ ;; A file-like object
+ (util-linux-package console-blank-configuration-util-linux-package
+ (default util-linux))
+ ;; An integer
+ (blank-time console-blank-configuration-blank-time
+ (default 10))
+ ;; An integer
+ (powerdown-time console-blank-configuration-powerdown-time
+ (default 10)))
+
+(define (console-blank-shepherd-services config)
+ "Return a list of one shepherd services setting up Linux console screen
+blanking and powerdown times, configurable by CONFIG, a record of the
+<console-blank-configuration> type."
+ (let ((util-linux (console-blank-configuration-util-linux-package config))
+ (blank (number->string
+ (console-blank-configuration-blank-time config)))
+ (powerdown (number->string
+ (console-blank-configuration-powerdown-time config))))
+ (list
+ (shepherd-service
+ (documentation "Setup Linux console screen blanking and powerdown.")
+ (provision (list 'console-blank))
+
+ ;; Start after mingetty has been started on tty1
+ (requirement (list 'term-tty1 'console-font-tty1))
+
+ (start #~(lambda _
+ (case (status:exit-val
+ (system
+ (string-append #$(file-append util-linux
+ "/bin/setterm")
+ " --blank="
+ #$blank
+ " --powerdown="
+ #$powerdown
+ " </dev/tty1 >/dev/tty1")))
+ ((0) #t)
+ (else #f))))
+ (stop #~(const #f))
+ (respawn? #f)))))
+
+(define console-blank-service-type
+ (service-type
+ (name 'console-blank)
+ (description "Setup screen blanking and powerdown on the Linux console")
+ (extensions
+ (list (service-extension shepherd-root-service-type
+ console-blank-shepherd-services)
+ (service-extension
+ profile-service-type
+ (lambda (config)
+ (list
+ (console-blank-configuration-util-linux-package config))))))
+ (default-value (console-blank-configuration))))
diff --git a/whispers/services/dict.scm b/whispers/services/dict.scm
new file mode 100644
index 0000000..8c481f5
--- /dev/null
+++ b/whispers/services/dict.scm
@@ -0,0 +1,146 @@
+;;; Whispers --- Stealth VPN and ssh tunneler
+;;; Copyright © 2024 Runciter <runciter@whispers-vpn.org>
+;;;
+;;; This file is part of Whispers.
+;;;
+;;; Whispers 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.
+;;;
+;;; Whispers 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 Whispers. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (whispers services dict)
+ #:use-module (guix gexp)
+ #:use-module (gnu services dict)
+ #:use-module (whispers packages dict)
+ #:export (%dictorg-handler
+ freedict-dictorg-database
+ %freedict-dictorg-databases
+ %cedict-dictorg-databases))
+
+(define %dictorg-handler
+ (dicod-handler (name "dictorg")
+ (module "dictorg")
+ (options (list #~(string-append "dbdir=/")))))
+
+(define (freedict-dictorg-database dict-name)
+ "Return a record of type @code{<dicod-database>} that configures a
+database for the freedict multilingual dictionary named by the string
+DICT-NAME."
+ (dicod-database (name (string-append "freedict-"
+ dict-name))
+ (complex? #t)
+ (handler "dictorg")
+ (options (list #~(string-append "database="
+ #$freedict-dictionaries
+ "/share/dictd/"
+ #$dict-name)))))
+(define %freedict-dictorg-databases
+ (map freedict-dictorg-database (list "afr-deu"
+ "afr-eng"
+ "ara-eng"
+ "bre-fra"
+ "ces-eng"
+ "ckb-kmr"
+ "cym-eng"
+ "dan-eng"
+ "deu-ita"
+ "deu-kur"
+ "deu-nld"
+ "deu-por"
+ "deu-tur"
+ "eng-afr"
+ "eng-ara"
+ "eng-ces"
+ "eng-cym"
+ "eng-dan"
+ "eng-ell"
+ "eng-fra"
+ "eng-gle"
+ "eng-hin"
+ "eng-hrv"
+ "eng-hun"
+ "eng-ita"
+ "eng-lat"
+ "eng-lit"
+ "eng-nld"
+ "eng-pol"
+ "eng-por"
+ "eng-rom"
+ "eng-rus"
+ "eng-spa"
+ "eng-srp"
+ "eng-swh"
+ "eng-tur"
+ "fra-bre"
+ "fra-eng"
+ "fra-nld"
+ "gla-deu"
+ "gle-eng"
+ "gle-pol"
+ "hrv-eng"
+ "hun-eng"
+ "isl-eng"
+ "ita-deu"
+ "ita-eng"
+ "jpn-deu"
+ "jpn-eng"
+ "jpn-fra"
+ "jpn-rus"
+ "kha-deu"
+ "kha-eng"
+ "kur-deu"
+ "kur-eng"
+ "kur-tur"
+ "lat-deu"
+ "lat-eng"
+ "lit-eng"
+ "mkd-bul"
+ "nld-deu"
+ "nld-eng"
+ "nld-fra"
+ "nno-nob"
+ "oci-cat"
+ "pol-gle"
+ "por-deu"
+ "por-eng"
+ "san-deu"
+ "slk-eng"
+ "slv-eng"
+ "spa-ast"
+ "spa-eng"
+ "spa-por"
+ "srp-eng"
+ "swe-eng"
+ "swh-eng"
+ "swh-pol"
+ "tur-deu"
+ "tur-eng"
+ "wol-fra")))
+
+(define (cedict-dictorg-database variant)
+ "Return a record of type @code{<dicod-database>} that configures a
+database for the CC-CEDICT chinese-english multilingual dictionary
+variant described by the string VARIANT."
+ (dicod-database (name (string-append "cedict-"
+ variant))
+ (complex? #t)
+ (handler "dictorg")
+ (options (list #~(string-append "database="
+ #$cc-cedict
+ "/share/cc-cedict/cedict-"
+ #$variant)))))
+
+(define %cedict-dictorg-databases
+ (map cedict-dictorg-database (list "bare"
+ "numb"
+ "pinyin"
+ "smpl"
+ "trad")))
diff --git a/whispers/services/finance.scm b/whispers/services/finance.scm
new file mode 100644
index 0000000..dd20248
--- /dev/null
+++ b/whispers/services/finance.scm
@@ -0,0 +1,283 @@
+;;; Whispers --- Stealth VPN and ssh tunneler
+;;; Copyright © 2023 Runciter <runciter@whispers-vpn.org>
+;;;
+;;; This file is part of Whispers.
+;;;
+;;; Whispers 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.
+;;;
+;;; Whispers 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 Whispers. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (whispers services finance)
+ #:use-module (guix gexp)
+ #:use-module (guix records)
+ #:use-module (gnu services)
+ #:use-module (gnu services shepherd)
+ #:use-module (gnu services admin)
+ #:use-module (gnu packages finance)
+ #:export (bitcoin-configuration
+ bitcoin-service-type
+ bitcoin-configuration?
+ bitcoin-service-type
+ monero-configuration
+ monero-service-type
+ monero-configuration?
+ monero-service-type))
+
+(define-record-type* <bitcoin-configuration>
+ bitcoin-configuration make-bitcoin-configuration
+ bitcoin-configuration?
+ this-bitcoin-configuration
+ ;; A file-like object
+ (bitcoin-package bitcoin-configuration-bitcoin-package
+ (default bitcoin-core))
+ ;; A string
+ (user bitcoin-configuration-user
+ (default "johndoe"))
+ ;; A boolean value
+ (walletdir-opt? bitcoin-configuration-walletdir-opt?
+ (default #f))
+ ;; A string
+ (walletdir bitcoin-configuration-walletdir
+ (default ""))
+ ;; A boolean value
+ (proxy-opt? bitcoin-configuration-proxy-opt?
+ (default #f))
+ ;; A string
+ (proxy bitcoin-configuration-proxy
+ (default ""))
+ ;; A string
+ (pid bitcoin-configuration-pid
+ (default ""))
+ ;; A string
+ (log-folder bitcoin-configuration-log-folder
+ (default "/var/run"))
+ ;; A string
+ (log-file-name bitcoin-configuration-log-file-name
+ (default "bitcoin.log"))
+ ;; A boolean value
+ (%auto-start? bitcoin-configuration-auto-start?
+ (default #t)))
+
+(define-record-type* <monero-configuration>
+ monero-configuration make-monero-configuration
+ monero-configuration?
+ this-monero-configuration
+ ;; A file-like object
+ (monero-package monero-configuration-monero-package
+ (default monero))
+ ;; A string
+ (user monero-configuration-user
+ (default "johndoe"))
+ ;; A boolean value
+ (proxy-opt? monero-configuration-proxy-opt?
+ (default #f))
+ ;; A string
+ (proxy monero-configuration-proxy
+ (default ""))
+ ;; A boolean value
+ (tx-proxy-opt? monero-configuration-tx-proxy-opt?
+ (default #f))
+ ;; A string
+ (tx-proxy monero-configuration-tx-proxy
+ (default ""))
+ ;; A boolean value
+ (prune-blockchain-opt? monero-configuration-prune-blockchain-opt?
+ (default #f))
+ ;; A string
+ (pidfile monero-configuration-pidfile
+ (default ""))
+ ;; An integer
+ (pid-file-timeout monero-configuration-pid-file-timeout
+ (default 5))
+ ;; A string
+ (log-folder monero-configuration-log-folder
+ (default "/var/run"))
+ ;; A string
+ (stdout-log-file-name monero-configuration-stdout-log-file-name
+ (default "monero.log"))
+ ;; A string
+ (monero-log-file-name monero-configuration-monero-log-file-name
+ (default "bitmonero.log"))
+ ;; A boolean value
+ (%auto-start? monero-configuration-auto-start?
+ (default #t)))
+
+(define (bitcoin-log-file-path config)
+ "Returns a string specifying the path to the log file of a bitcoin
+node service configurable by CONFIG, a record of the
+<bitcoin-configuration> type."
+ (string-append (bitcoin-configuration-log-folder config)
+ "/"
+ (bitcoin-configuration-log-file-name config)))
+
+(define (bitcoin-log-rotation config)
+ "Returns a list of log-rotation records specifying how to rotate the
+logs of a bitvoin node service configurable by CONFIG, a record of the
+<bitcoin-configuration> type."
+ (list (log-rotation (frequency 'daily)
+ (files `(,(bitcoin-log-file-path config))))))
+
+(define (bitcoin-constructor-gexp config)
+ "Returns a G-exp to a procedure starting a bitcoin node daemon,
+configurable by CONFIG, a record of the <bitcoin-configuration> type."
+ (let ((bitcoin-package (bitcoin-configuration-bitcoin-package config))
+ (user (bitcoin-configuration-user config))
+ (walletdir-opt? (bitcoin-configuration-walletdir-opt? config))
+ (walletdir (bitcoin-configuration-walletdir config))
+ (proxy-opt? (bitcoin-configuration-proxy-opt? config))
+ (proxy (bitcoin-configuration-proxy config))
+ (pid-file-path (bitcoin-configuration-pid config))
+ (log-file-path (bitcoin-log-file-path config)))
+ #~(make-forkexec-constructor
+ (append (list #$(file-append bitcoin-package
+ "/bin/bitcoind")
+ (string-append "-datadir="
+ (passwd:dir (getpwnam #$user))
+ "/.bitcoin"))
+ (if #$walletdir-opt?
+ (list (string-append "-walletdir="
+ #$walletdir))
+ (list))
+ (if #$proxy-opt?
+ (list (string-append "-proxy="
+ #$proxy))
+ (list))
+ (list (string-append "-pid="
+ #$pid-file-path)))
+ #:pid-file
+ #$pid-file-path
+ #:log-file
+ #$log-file-path)))
+
+(define (bitcoin-shepherd-services config)
+ "Returns a list of shepherd services handling a bitcoin node
+configured by CONFIG, a record of the <bitcoin-configuration> type."
+ (let ((auto-start? (bitcoin-configuration-auto-start? config)))
+ (list
+ (shepherd-service
+ (documentation "Bitcoin node")
+ (provision '(bitcoin))
+ (requirement '())
+ (start (bitcoin-constructor-gexp config))
+ (stop #~(make-kill-destructor))
+ (auto-start? auto-start?)))))
+
+(define bitcoin-service-type
+ (service-type
+ (name 'bitcoin)
+ (description "Bitcoin node service")
+ (extensions
+ (list (service-extension shepherd-root-service-type
+ bitcoin-shepherd-services)
+ (service-extension rottlog-service-type
+ bitcoin-log-rotation)
+ (service-extension
+ profile-service-type
+ (lambda (config)
+ (list (bitcoin-configuration-bitcoin-package config))))))
+ (default-value (bitcoin-configuration))))
+
+(define (stdout-monero-log-file-path config)
+ "Returns a string specifying the path to the log file of the standard
+output of a monero node service configurable by CONFIG, a record of the
+<monero-configuration> type."
+ (string-append (monero-configuration-log-folder config)
+ "/"
+ (monero-configuration-stdout-log-file-name config)))
+
+(define (monero-log-file-path config)
+ "Returns a string specifying the path to the log file of a monero node
+service configurable by CONFIG, a record of the <monero-configuration>
+type."
+ (string-append (monero-configuration-log-folder config)
+ "/"
+ (monero-configuration-monero-log-file-name config)))
+
+(define (monero-log-rotation config)
+ "Returns a list of log-rotation records specifying how to rotate the
+logs of a monero node service configurable by CONFIG, a record of
+the <monero-configuration> type."
+ (list (log-rotation (frequency 'daily)
+ (files `(,(monero-log-file-path config))))
+ (log-rotation (frequency 'daily)
+ (files `(,(stdout-monero-log-file-path config))))))
+
+(define (monero-constructor-gexp config)
+ "Returns a G-exp to a procedure starting a monero node daemon,
+configurable by CONFIG, a record of the <monero-configuration> type."
+ (let ((monero-package (monero-configuration-monero-package config))
+ (user (monero-configuration-user config))
+ (proxy-opt? (monero-configuration-proxy-opt? config))
+ (proxy (monero-configuration-proxy config))
+ (tx-proxy-opt? (monero-configuration-tx-proxy-opt? config))
+ (tx-proxy (monero-configuration-tx-proxy config))
+ (pid-file-path (monero-configuration-pidfile config))
+ (prune? (monero-configuration-prune-blockchain-opt? config))
+ (pid-file-timeout (monero-configuration-pid-file-timeout config))
+ (log-file-path ( monero-log-file-path config))
+ (stdout-log-file-path (stdout-monero-log-file-path config)))
+ #~(make-forkexec-constructor
+ (append (list #$(file-append monero-package
+ "/bin/monerod")
+ "--data-dir"
+ (string-append (passwd:dir (getpwnam #$user))
+ "/.bitmonero"))
+ (if #$proxy-opt?
+ (list "--proxy"
+ #$proxy)
+ (list))
+ (if #$tx-proxy-opt?
+ (list "--tx-proxy"
+ #$tx-proxy)
+ (list))
+ (if #$prune?
+ (list "--prune-blockchain")
+ (list))
+ (list "--detach"
+ "--pid"
+ #$pid-file-path
+ "--log-file"
+ #$log-file-path))
+ #:pid-file
+ #$pid-file-path
+ #:pid-file-timeout
+ #$pid-file-timeout
+ #:log-file
+ #$stdout-log-file-path)))
+
+(define (monero-shepherd-services config)
+ "Returns a list of shepherd services handling a monero node
+configured by CONFIG, a record of the <monero-configuration> type."
+ (let ((auto-start? (monero-configuration-auto-start? config)))
+ (list
+ (shepherd-service
+ (documentation "Monero node")
+ (provision '(monero))
+ (requirement '())
+ (start (monero-constructor-gexp config))
+ (stop #~(make-kill-destructor))
+ (auto-start? auto-start?)))))
+
+(define monero-service-type
+ (service-type
+ (name 'monero)
+ (description "Monero node service")
+ (extensions
+ (list (service-extension shepherd-root-service-type
+ monero-shepherd-services)
+ (service-extension rottlog-service-type
+ monero-log-rotation)
+ (service-extension
+ profile-service-type
+ (lambda (config)
+ (list (monero-configuration-monero-package config))))))
+ (default-value (monero-configuration))))
diff --git a/whispers/services/gps.scm b/whispers/services/gps.scm
new file mode 100644
index 0000000..5c1b33f
--- /dev/null
+++ b/whispers/services/gps.scm
@@ -0,0 +1,102 @@
+;;; Whispers --- Stealth VPN and ssh tunneler
+;;; Copyright © 2024 Runciter <runciter@whispers-vpn.org>
+;;;
+;;; This file is part of Whispers.
+;;;
+;;; Whispers 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.
+;;;
+;;; Whispers 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 Whispers. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (whispers services gps)
+ #:use-module (guix records)
+ #:use-module (guix gexp)
+ #:use-module (gnu services)
+ #:use-module (gnu services shepherd)
+ #:use-module (gnu services admin)
+ #:use-module (gnu packages gps)
+ #:export (gpsd-configuration
+ gpsd-configuration?
+ gpsd-service-type))
+
+(define-record-type* <gpsd-configuration>
+ gpsd-configuration make-gpsd-configuration
+ gpsd-configuration?
+ this-gpsd-configuration
+ ;; A file-like object
+ (gpsd-package gpsd-configuration-gpsd-package
+ (default gpsd))
+ ;; A symbol
+ (provision gpsd-configuration-provision
+ (default (string->symbol
+ (string-append
+ "gpsd-"
+ (number->string
+ (gpsd-configuration-port
+ this-gpsd-configuration)))))
+ (thunked))
+ ;; A string
+ (source gpsd-configuration-source
+ (default "/dev/ttyUSB0"))
+ ;; An integer
+ (port gpsd-configuration-port
+ (default 2947))
+ ;; An integer
+ (listen-any? gpsd-configuration-listen-any?
+ (default #f))
+ ;; A boolean value
+ (%auto-start? gpsd-configuration-auto-start?
+ (default #t)))
+
+(define (constructor-gexp config)
+ "Returns a G-exp to start a gpsd shepherd service, configurable by
+CONFIG, a record of the <gpsd-configuration> type."
+ (let ((gpsd-package (gpsd-configuration-gpsd-package config))
+ (listen-any? (gpsd-configuration-listen-any? config))
+ (port (gpsd-configuration-port config))
+ (source (gpsd-configuration-source config)))
+ #~(make-forkexec-constructor (append (list #$(file-append gpsd-package
+ "/sbin/gpsd")
+ "-N"
+ "-P"
+ #$(number->string port))
+ (if #$listen-any?
+ (list "-G")
+ (list))
+ (list #$source)))))
+
+(define (gpsd-shepherd-services config)
+ "Returns a list of shepherd services handling a gpsd daemon
+configured by CONFIG, a record of the <gpsd-configuration>
+type."
+ (let ((auto-start? (gpsd-configuration-auto-start? config)))
+ (list
+ (shepherd-service
+ (documentation (string-append "gpsd service."))
+ (provision (list (gpsd-configuration-provision config)))
+ (requirement '())
+ (start (constructor-gexp config))
+ (stop #~(make-kill-destructor))
+ (auto-start? auto-start?)))))
+
+(define gpsd-service-type
+ (service-type
+ (name 'gpsd)
+ (description "gpsd service")
+ (extensions
+ (list (service-extension shepherd-root-service-type
+ gpsd-shepherd-services)
+ (service-extension
+ profile-service-type
+ (lambda (config)
+ (list
+ (gpsd-configuration-gpsd-package config))))))
+ (default-value (gpsd-configuration))))
diff --git a/whispers/services/proton.scm b/whispers/services/proton.scm
new file mode 100644
index 0000000..41bf197
--- /dev/null
+++ b/whispers/services/proton.scm
@@ -0,0 +1,117 @@
+;;; Whispers --- Stealth VPN and ssh tunneler
+;;; Copyright © 2024 Runciter <runciter@whispers-vpn.org>
+;;;
+;;; This file is part of Whispers.
+;;;
+;;; Whispers 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.
+;;;
+;;; Whispers 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 Whispers. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (whispers services proton)
+ #:use-module (guix gexp)
+ #:use-module (guix records)
+ #:use-module (gnu services)
+ #:use-module (gnu services shepherd)
+ #:use-module (gnu services admin)
+ #:use-module (gnu packages mail)
+ #:export (hydroxide-configuration
+ hydroxide-service-type
+ hydroxide-configuration?
+ hydroxide-service-type))
+
+(define-record-type* <hydroxide-configuration>
+ hydroxide-configuration make-hydroxide-configuration
+ hydroxide-configuration?
+ this-hydroxide-configuration
+ ;; A file-like object
+ (hydroxide-package hydroxide-configuration-hydroxide-package
+ (default hydroxide))
+ ;; A string
+ (user hydroxide-configuration-user
+ (default "johndoe"))
+ ;; A boolean value
+ (https-proxy? hydroxide-configuration-https-proxy?
+ (default #f))
+ ;; A string
+ (https-proxy hydroxide-configuration-https-proxy
+ (default "socks5://localhost:8971"))
+ ;; A boolean value
+ (imap? hydroxide-configuration-imap?
+ (default #t))
+ ;; A boolean value
+ (smtp? hydroxide-configuration-smtp?
+ (default #t))
+ ;; A boolean value
+ (carddav? hydroxide-configuration-carddav?
+ (default #t))
+ ;; A boolean value
+ (%auto-start? hydroxide-configuration-auto-start?
+ (default #t)))
+
+(define (hydroxide-constructor-gexp config)
+ "Returns a G-exp to a procedure starting an hydroxide server
+configurable by CONFIG, a record of the <hydroxide-configuration> type."
+ (let ((hydroxide-package (hydroxide-configuration-hydroxide-package
+ config))
+ (user (hydroxide-configuration-user config))
+ (https-proxy? (hydroxide-configuration-https-proxy? config))
+ (https-proxy (hydroxide-configuration-https-proxy config))
+ (imap? (hydroxide-configuration-imap? config))
+ (carddav? (hydroxide-configuration-carddav? config))
+ (smtp? (hydroxide-configuration-smtp? config)))
+ #~(make-forkexec-constructor
+ (append (list #$(file-append hydroxide-package
+ "/bin/hydroxide"))
+ (if #$imap?
+ (list)
+ (list "--disable-imap"))
+ (if #$carddav?
+ (list)
+ (list "--disable-carddav"))
+ (if #$smtp?
+ (list)
+ (list "--disable-smtp"))
+ (list "serve"))
+ #:environment-variables
+ (append (list (string-append "XDG_CONFIG_HOME="
+ (passwd:dir (getpwnam #$user))
+ "/.config"))
+ #$(if https-proxy?
+ #~(list (string-append "https_proxy="
+ #$https-proxy))
+ #~(list))))))
+
+(define (hydroxide-shepherd-services config)
+ "Returns a list of shepherd services handling an hydroxide server
+configured by CONFIG, a record of the <hydroxide-configuration> type."
+ (let ((auto-start? (hydroxide-configuration-auto-start? config)))
+ (list
+ (shepherd-service
+ (documentation "Hydroxide service")
+ (provision '(hydroxide))
+ (requirement '())
+ (start (hydroxide-constructor-gexp config))
+ (stop #~(make-kill-destructor))
+ (auto-start? auto-start?)))))
+
+(define hydroxide-service-type
+ (service-type
+ (name 'hydroxide)
+ (description "Hydroxide node service")
+ (extensions
+ (list (service-extension shepherd-root-service-type
+ hydroxide-shepherd-services)
+ (service-extension
+ profile-service-type
+ (lambda (config)
+ (list (hydroxide-configuration-hydroxide-package config))))))
+ (default-value (hydroxide-configuration))))
diff --git a/whispers/services/ssh-agent.scm b/whispers/services/ssh-agent.scm
new file mode 100644
index 0000000..834b36a
--- /dev/null
+++ b/whispers/services/ssh-agent.scm
@@ -0,0 +1,153 @@
+;;; Whispers --- Stealth VPN and ssh tunneler
+;;; Copyright © 2023 Runciter <runciter@whispers-vpn.org>
+;;;
+;;; This file is part of Whispers.
+;;;
+;;; Whispers 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.
+;;;
+;;; Whispers 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 Whispers. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (whispers services ssh-agent)
+ #:use-module (guix gexp)
+ #:use-module (guix records)
+ #:use-module (gnu services)
+ #:use-module (gnu services shepherd)
+ #:use-module (gnu services admin)
+ #:use-module (gnu packages ssh)
+ #:export (ssh-agent-configuration
+ ssh-agent-configuration?
+ ssh-agent-service-type))
+
+(define-record-type* <ssh-agent-configuration>
+ ssh-agent-configuration make-ssh-agent-configuration
+ ssh-agent-configuration?
+ this-ssh-agent-configuration
+ ;; A file-like object
+ (ssh-package ssh-agent-configuration-ssh-package
+ (default openssh))
+ ;; A string
+ (socket-folder ssh-agent-configuration-socket-folder
+ (default "/var/run/ssh-agent"))
+ ;; A string
+ (socket-file-name ssh-agent-configuration-socket-file-name
+ (default "ssh-agent.sock"))
+ ;; A string
+ (log-folder ssh-agent-configuration-log-folder
+ (default "/var/log"))
+ ;; A string
+ (log-file-name ssh-agent-configuration-log-file-name
+ (default "ssh-agent.log"))
+ ;; A list of strings
+ (auto-added-keys ssh-agent-configuration-auto-added-keys
+ (default '()))
+ ;; A boolean value
+ (%auto-start? ssh-agent-configuration-auto-start?
+ (default #t)))
+
+(define (socket-file-path config)
+ "Returns a string specifying the path to the log file of an ssh agent
+service configurable by CONFIG, a record of the
+<ssh-agent-configuration> type."
+ (string-append (ssh-agent-configuration-socket-folder config)
+ "/"
+ (ssh-agent-configuration-socket-file-name config)))
+
+(define (log-file-path config)
+ "Returns a string specifying the path to the log file of an ssh agent
+service configurable by CONFIG, a record of the
+<ssh-agent-configuration> type."
+ (string-append (ssh-agent-configuration-log-folder config)
+ "/"
+ (ssh-agent-configuration-log-file-name config)))
+
+(define (ssh-agent-log-rotation config)
+ "Returns a list of log-rotation records specifying how to rotate the
+logs of as ssh aggent service configurable by CONFIG, a record of
+the <ssh-agent-configuration> type."
+ (list (log-rotation (frequency 'daily)
+ (files `(,(log-file-path config))))))
+
+(define (add-key-procedure config)
+ "Returns a G-exp to a procedure adding a private key to a running ssh
+agent daemon, configurable by CONFIG, a record of the
+<ssh-agent-configuration> type."
+ (let ((ssh-package (ssh-agent-configuration-ssh-package config)))
+ #~(lambda (running key-path)
+ ((make-system-constructor
+ (string-append "SSH_AUTH_SOCK="
+ #$(socket-file-path config)
+ " "
+ #$(file-append ssh-package
+ "/bin/ssh-add")
+ " "
+ key-path))))))
+
+(define (constructor-gexp config)
+ "Returns a G-exp to a procedure adding a private key to a running ssh
+agent daemon, configurable by CONFIG, a record of the
+<ssh-agent-configuration> type."
+ (let ((ssh-package (ssh-agent-configuration-ssh-package config))
+ (auto-added-keys (ssh-agent-configuration-auto-added-keys config))
+ (socket-file-path (socket-file-path config))
+ (log-file-path (log-file-path config)))
+ #~(lambda whatever
+ (let ((ret ((make-forkexec-constructor
+ (list #$(file-append ssh-package
+ "/bin/ssh-agent")
+ "-d"
+ "-a"
+ #$socket-file-path)
+ #:log-file
+ #$log-file-path))))
+ (map (lambda (key)
+ (action 'ssh-agent 'add-key key))
+ '#$auto-added-keys)
+ ret))))
+
+(define (ssh-agent-shepherd-services config)
+ "Returns a list of shepherd services handling an ssh agent daemon
+configured by CONFIG, a record of the <ssh-agent-configuration>
+type."
+ (let ((auto-start? (ssh-agent-configuration-auto-start? config)))
+ (list
+ (shepherd-service
+ (documentation (string-append "Ssh agent service, socket file can
+be found at "
+ (socket-file-path config)
+ "."))
+ (provision '(ssh-agent))
+ (requirement '())
+ (start (constructor-gexp config))
+ (stop #~(make-kill-destructor))
+ (actions
+ (list
+ (shepherd-action (name 'add-key)
+ (documentation "Add the private key found at at
+the path KEY-PATH to a started ssh-agent daemon.")
+ (procedure (add-key-procedure config)))))
+ (auto-start? auto-start?)))))
+
+(define ssh-agent-service-type
+ (service-type
+ (name 'ssh-agent)
+ (description "Ssh agent service")
+ (extensions
+ (list (service-extension shepherd-root-service-type
+ ssh-agent-shepherd-services)
+ (service-extension rottlog-service-type
+ ssh-agent-log-rotation)
+ (service-extension
+ profile-service-type
+ (lambda (config)
+ (list
+ (ssh-agent-configuration-ssh-package config))))))
+ (default-value (ssh-agent-configuration))))
diff --git a/whispers/services/ssh-tunneler.scm b/whispers/services/ssh-tunneler.scm
new file mode 100644
index 0000000..18cb4f3
--- /dev/null
+++ b/whispers/services/ssh-tunneler.scm
@@ -0,0 +1,904 @@
+;;; Whispers --- Stealth VPN and ssh tunnelerq
+;;; Copyright © 2023 Runciter <runciter@whispers-vpn.org>
+;;;
+;;; This file is part of Whispers.
+;;;
+;;; Whispers 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.
+;;;
+;;; Whispers 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 Whispers. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (whispers services ssh-tunneler)
+ #:use-module (guix gexp)
+ #:use-module (guix records)
+ #:use-module (gnu services)
+ #:use-module (gnu services shepherd)
+ #:use-module (gnu services admin)
+ #:use-module (gnu services mcron)
+ #:use-module (whispers services whispers)
+ #:use-module (gnu packages base)
+ #:use-module (gnu packages admin)
+ #:use-module (gnu packages linux)
+ #:use-module (gnu packages ssh)
+ #:use-module (whispers packages doc)
+ #:use-module (gnu home services)
+ #:use-module (gnu home services shepherd)
+ #:export (ssh-connection-configuration
+ make-ssh-connection-configuration
+ ssh-connection-configuration?
+ this-ssh-connection-configuration
+ ssh-connection-configuration-forwards
+ ssh-forward-configuration
+ this-ssh-forward-configuration
+ ssh-forward-configuration?
+ make-ssh-forward-configuration
+ ssh-forward-configuration-entry-port
+ socks-proxy-configuration
+ this-socks-proxy-configuration
+ socks-proxy-configuration?
+ make-socks-proxy-configuration
+ dynamic-forward-configuration
+ port-forward-configuration
+ reverse-port-forward-configuration
+ tunnel-forward-configuration
+ persistent-ssh-name
+ persistent-ssh-service-type
+ home-persistent-ssh-service-type))
+
+(define-record-type* <ssh-connection-configuration>
+ ssh-connection-configuration make-ssh-connection-configuration
+ ssh-connection-configuration?
+ this-ssh-connection-configuration
+ ;; A file-like object.
+ (shepherd-package ssh-connection-configuration-shepherd-package
+ (default shepherd))
+ ;; A file-like object.
+ (ssh-package ssh-connection-configuration-ssh-package
+ (default openssh))
+ ;; A file-like object.
+ (netcat-package ssh-connection-configuration-netcat-package
+ (default netcat-openbsd))
+ ;; A file-like object.
+ (sshpass-package ssh-connection-configuration-sshpass-package
+ (default sshpass))
+ ;; A file-like object.
+ (ineutils-package ssh-connection-configuration-inetutils-package
+ (default inetutils))
+ ;; A file-like object.
+ (procps-package ssh-connection-configuration-procps-package
+ (default procps))
+ ;; A guix record of type <socks-proxy-configuration>.
+ (socks-proxy-config ssh-connection-configuration-socks-proxy-config
+ (default (socks-proxy-configuration)))
+ ;; A boolean value.
+ (agent? ssh-connection-configuration-agent?
+ (default #f))
+ (agent-socket ssh-connection-configuration-agent-socket
+ (default ""))
+ ;; A boolean value.
+ ;; A string.
+ ;; It is thinked so that the use-agent? switch of
+ ;; <whispers-forwardings> binds both agent? and is-rea-file in
+ ;; opposite states, without exposing this detail to the user.
+ (id-rsa-file? ssh-connection-configuration-id-rsa-file?
+ (default (not
+ (ssh-connection-configuration-agent?
+ this-ssh-connection-configuration)))
+ (thunked))
+ ;; A string.
+ (id-rsa-file ssh-connection-configuration-id-rsa-file
+ (default "/root/.ssh/id_rsa"))
+ ;; A boolean value.
+ (clear-password? ssh-connection-configuration-clear-password?
+ (default #f))
+ ;; A string.
+ (sshd-user-password ssh-connection-configuration-sshd-user-password
+ (default "none"))
+ ;; A string.
+ (sshd-user ssh-connection-configuration-sshd-user
+ (default "root"))
+ ;; A string.
+ (sshd-host ssh-connection-configuration-sshd-host
+ (default "127.0.0.1"))
+ ;; An integer.
+ (sshd-port ssh-connection-configuration-sshd-port
+ (default 22))
+ ;; A boolean value.
+ (gateway-ports? ssh-connection-configuration-gateway-ports?
+ (default #t))
+ ;; A list of strings.
+ (known-hosts-files ssh-connection-configuration-known-hosts-files
+ (default (list "~/.ssh/known_hosts"
+ "~/.ssh/known_hosts2")))
+ ;; A string.
+ (strict-check ssh-connection-configuration-strict-check
+ (default "yes"))
+ ;; An integer.
+ (server-alive-interval ssh-connection-configuration-server-alive-interval
+ (default 30))
+ ;; An integer.
+ (server-alive-count-max ssh-connection-configuration-server-alive-count-max
+ (default 6))
+ ;; A string.
+ (name-prefix ssh-connection-configuration-name-prefix
+ (default "ssh-forwards"))
+ ;; A boolean value.
+ (suffix-name? ssh-connection-configuration-suffix-name?
+ (default #t))
+ ;; A list of strings.
+ (special-options ssh-connection-configuration-special-options
+ (default (list)))
+ ;; A list of <ssh-forward-configuration> records.
+ (forwards ssh-connection-configuration-forwards
+ (default '()))
+ ;; A boolean value.
+ (exit-forward-failure? ssh-connection-configuration-exit-forward-failure?
+ (default #t))
+ ;; An integer.
+ (connection-attempts ssh-connection-configuration-connection-attempts
+ (default 1))
+ ;; A boolean value.
+ (local-command? ssh-connection-configuration-local-command?
+ (default (ssh-connection-configuration-pid-file?
+ this-ssh-connection-configuration))
+ (thunked))
+ ;; A list of strings
+ (extra-local-commands ssh-connection-configuration-extra-local-commands
+ (default '()))
+ ;; A boolean value.
+ (require-networking? ssh-connection-configuration-require-networking?
+ (default #t))
+ ;; A list of symbols.
+ (extra-requires ssh-connection-configuration-extra-requires
+ (default '()))
+ ;; A boolean value.
+ (elogind? ssh-connection-configuration-elogind?
+ (default #f))
+ ;; A boolean value.
+ (lieutenant? ssh-connection-configuration-lieutenant?
+ (default #f))
+ ;; A string.
+ (lieutenant-path ssh-connection-configuration-lieutenant-path
+ (default ""))
+ ;; A boolean value.
+ (pid-file? ssh-connection-configuration-pid-file?
+ (default #t))
+ ;; A boolean value.
+ (pid-folder-override? ssh-connection-configuration-pid-folder-override?
+ (default #f))
+ ;; A string.
+ (pid-folder-override ssh-connection-configuration-pid-folder-override
+ (default "/var/run"))
+ ;; A boolean value.
+ (timeout-override? ssh-connection-configuration-timeout-override?
+ (default #f))
+ ;; An integer.
+ (timeout-override ssh-connection-configuration-timeout-override
+ (default 5))
+ ;; A boolean value.
+ (dedicated-log-file? ssh-connection-configuration-dedicated-log-file?
+ (default #f))
+ ;; A boolean value.
+ (log-rotate? ssh-connection-configuration-log-rotate?
+ (default #f))
+ ;; A boolean value.
+ (log-folder-override? ssh-connection-configuration-log-folder-override?
+ (default #f))
+ ;; A string.
+ (log-folder-override ssh-connection-configuration-log-folder-override
+ (default "/var/run"))
+ ;; An integer between 0 and 3, both included.
+ (verbosity ssh-connection-configuration-verbosity
+ (default 0))
+ ;; A boolean value.
+ (command? ssh-connection-configuration-command?
+ (default #f))
+ ;; A string.
+ (command ssh-connection-configuration-command
+ (default '()))
+ ;; A quoted cron job time specification.
+ (resurrect-time-spec ssh-connection-configuration-resurrect-time-spec
+ (default ''(next-minute '(47))))
+ ;; A boolean value.
+ (flat-resurrect? ssh-connection-configuration-flat-resurrect?
+ (default #f))
+ ;; A quoted cron job time specification.
+ (force-resurrect-time-spec
+ ssh-connection-configuration-force-resurrect-time-spec
+ (default ''(next-hour '(3))))
+ ;; A boolean value.
+ (flat-force-resurrect? ssh-connection-configuration-flat-force-resurrect?
+ (default #f))
+ ;; A boolean value.
+ (%cron-resurrect? ssh-connection-configuration-cron-resurrect?
+ (default #f))
+ ;; A boolean value.
+ (%cron-force-resurrect? ssh-connection-configuration-cron-force-resurrect?
+ (default #f))
+ ;; A boolean value.
+ (%auto-start? ssh-connection-configuration-auto-start?
+ (default #f)))
+
+(define-record-type* <ssh-forward-configuration>
+ ssh-forward-configuration make-ssh-forward-configuration
+ ssh-forward-configuration?
+ this-ssh-forward-configuration
+ ;; A symbol which can be 'dynamic, 'port, 'reverse-port or 'tunnel
+ (forward-type ssh-forward-configuration-forward-type
+ (default 'dynamic))
+ ;; A symbol which can be 'preset or 'any when the 'forward-type field
+ ;; is 'tunnel, and which can be 'port or 'socket otherwise. It is
+ ;; ignored when the 'forward-type field is 'dynamic.
+ (entry-type ssh-forward-configuration-entry-type
+ (default 'port))
+ ;; A symbol which can be 'preset or 'any when the 'forward-type field
+ ;; is 'tunnel, and which can be 'port or 'socket otherwise. It is
+ ;; ignored when the 'forward-type field evaluates to 'dynamic.
+ (exit-type ssh-forward-configuration-exit-type
+ (default 'port))
+ ;; An integer
+ (entry-port ssh-forward-configuration-entry-port
+ (default 8971))
+ ;; An integer
+ (exit-port ssh-forward-configuration-exit-port
+ (default 22))
+ ;; A string
+ (entry-socket ssh-forward-configuration-entry-socket
+ (default ""))
+ ;; A string
+ (exit-socket ssh-forward-configuration-exit-socket
+ (default ""))
+ ;; A string
+ (forward-host ssh-forward-configuration-exit-host
+ (default "127.0.0.1"))
+ ;; An integer
+ (entry-tun ssh-forward-configuration-entry-tun
+ (default 0))
+ ;; An integer
+ (exit-tun ssh-forward-configuration-exit-tun
+ (default 0)))
+
+(define-record-type* <socks-proxy-configuration>
+ socks-proxy-configuration make-socks-proxy-configuration
+ socks-proxy-configuration?
+ this-socks-proxy-configuration
+ ;; A boolean value
+ (use-proxy? socks-proxy-configuration-use-proxy?
+ (default #f))
+ ;; A boolean value
+ (extend? socks-proxy-configuration-extend?
+ (default (socks-proxy-configuration-use-proxy?
+ this-socks-proxy-configuration))
+ (thunked))
+ ;; An integer
+ (port socks-proxy-configuration-port
+ (default
+ (if
+ (socks-proxy-configuration-extend?
+ this-socks-proxy-configuration)
+ (ssh-forward-configuration-entry-port
+ (car
+ (ssh-connection-configuration-forwards
+ (socks-proxy-configuration-dynamic-forward
+ this-socks-proxy-configuration))))
+ 8971))
+ (thunked))
+ ;; #f, or a guix record returned by a call to
+ ;; (ssh-connection-configuration
+ ;; (forwards (list (dynamic-forward-configuration ...)))
+ ;; ...)
+ (dynamic-forward socks-proxy-configuration-dynamic-forward
+ (default #f)))
+
+
+(define-syntax dynamic-forward-configuration
+ (syntax-rules ()
+ ((_ fields ...)
+ (ssh-forward-configuration
+ (inherit
+ (ssh-forward-configuration))
+ fields ...))))
+
+(define-syntax port-forward-configuration
+ (syntax-rules ()
+ ((_ fields ...)
+ (ssh-forward-configuration
+ (inherit
+ (ssh-forward-configuration (forward-type 'port)
+ (entry-port 6947)))
+ fields ...))))
+
+(define-syntax reverse-port-forward-configuration
+ (syntax-rules ()
+ ((_ fields ...)
+ (ssh-forward-configuration
+ (inherit
+ (ssh-forward-configuration (forward-type 'reverse-port)
+ (entry-port 6283)))
+ fields ...))))
+
+(define-syntax tunnel-forward-configuration
+ (syntax-rules ()
+ ((_ fields ...)
+ (ssh-forward-configuration
+ (inherit
+ (ssh-forward-configuration (forward-type 'tunnel)
+ (entry-type 'any)
+ (exit-type 'any)))
+ fields ...))))
+
+(define (persistent-ssh-socks-port config)
+ "Returns an integer defining the localhost port that a persistent ssh
+connection can use to establish itself through a socks proxy,
+configurable by CONFIG, a record of the <ssh-connection-configuration>
+type."
+ (socks-proxy-configuration-port
+ (ssh-connection-configuration-socks-proxy-config config)))
+
+(define (persistent-ssh-forward-stance forward-conf)
+ "Returns a string defining one of the forwarding stances of a
+persistent ssh connection, configurable by FORWARD-CONF, a record of the
+<ssh-forward-configuration> type."
+ (let* ((forward-type (ssh-forward-configuration-forward-type forward-conf))
+ (entry-type (ssh-forward-configuration-entry-type forward-conf))
+ (exit-type (ssh-forward-configuration-exit-type forward-conf))
+ (entry-port (ssh-forward-configuration-entry-port forward-conf))
+ (entry-port-str (number->string entry-port))
+ (exit-port (ssh-forward-configuration-exit-port forward-conf))
+ (exit-port-str (number->string exit-port))
+ (entry-socket (ssh-forward-configuration-entry-socket forward-conf))
+ (exit-socket (ssh-forward-configuration-exit-socket forward-conf))
+ (exit-host (ssh-forward-configuration-exit-host forward-conf))
+ (entry-tun (ssh-forward-configuration-entry-tun forward-conf))
+ (entry-tun-str (number->string entry-tun))
+ (exit-tun (ssh-forward-configuration-exit-tun forward-conf))
+ (exit-tun-str (number->string exit-tun)))
+ (cond ((equal? forward-type 'dynamic)
+ (number->string entry-port))
+ ((or (equal? forward-type 'port)
+ (equal? forward-type 'reverse-port))
+ (cond ((equal? entry-type 'port) (string-append entry-port-str
+ ":"
+ exit-host
+ ":"
+ exit-port-str))
+ ((equal? entry-type 'socket) (string-append entry-socket
+ ":"
+ exit-socket))
+ (#t #f)))
+ ((equal? forward-type 'tunnel)
+ (string-append (cond ((equal? entry-type 'preset) entry-tun-str)
+ ((equal? entry-type 'any) "any")
+ (#t #f))
+ ":"
+ (cond ((equal? exit-type 'preset) exit-tun-str)
+ ((equal? exit-type 'any) "any")
+ (#t #f))))
+ (#t
+ #f))))
+
+(define (persistent-ssh-forward-switch forward-conf)
+ "Returns a string defining one of the forwarding switches of a
+persistent ssh connection, configurable by FORWARD-CONF, a record of the
+<ssh-forward-configuration> type."
+ (let ((forward-type (ssh-forward-configuration-forward-type forward-conf)))
+ (cond ((equal? forward-type 'dynamic) "-D")
+ ((equal? forward-type 'port) "-L")
+ ((equal? forward-type 'reverse-port) "-R")
+ ((equal? forward-type 'tunnel) "-w")
+ (#t #f))))
+
+(define (persistent-ssh-forward forward-conf)
+ "Returns a list of 2 strings containing the switch and stance of one of the
+forwardings of a persistent ssh connection, configurable by
+FORWARD-CONF, a record of the <ssh-forward-configuration> type."
+ (list (persistent-ssh-forward-switch forward-conf)
+ (persistent-ssh-forward-stance forward-conf)))
+
+(define (persistent-ssh-name-suffix config)
+ "Returns a string defining the suffix part of the shepherd service
+provision of the shepherd service daemonizing a persistent ssh
+connection, configurable by CONFIG, a record of the
+<ssh-connection-configuration> type."
+ (let* ((forwards (ssh-connection-configuration-forwards config))
+ (typer ssh-forward-configuration-forward-type)
+ (typer-str (lambda (forward)
+ (symbol->string (typer forward))))
+ (stancer persistent-ssh-forward-stance)
+ (socks-rec (ssh-connection-configuration-socks-proxy-config config))
+ (use-socks? (socks-proxy-configuration-use-proxy? socks-rec))
+ (socks-port (socks-proxy-configuration-port socks-rec))
+ (socks-port-str (number->string socks-port))
+ (flat? (ssh-connection-configuration-flat-resurrect? config)))
+ (string-append "_"
+ (string-join (map (lambda (forward)
+ (string-append (typer-str forward)
+ "@"
+ (stancer forward)))
+ forwards)
+ "_")
+ (if use-socks?
+ (string-append "_proxy-port_"
+ socks-port-str)
+ ""))))
+
+(define (persistent-ssh-name config)
+ "Returns a symbol defining the shpherd service provision of the
+shepherd service daemonizing a persistent ssh connection, configurable
+by CONFIG, a record of the <ssh-connection-configuration> type."
+ (string->symbol
+ (string-append (ssh-connection-configuration-name-prefix config)
+ (if (ssh-connection-configuration-suffix-name? config)
+ (persistent-ssh-name-suffix config)
+ ""))))
+
+(define (persistent-ssh-pid-folder config)
+ "Returns a string defining the path to the folder in which the pid
+file of a persistent ssh connection service is stored by default,
+configurable by CONFIG, a record of the <ssh-connection-configuration>
+type."
+ (cond ((ssh-connection-configuration-pid-folder-override? config)
+ (ssh-connection-configuration-pid-folder-override config))
+ ((ssh-connection-configuration-elogind? config)
+ (string-append "/run/user/" (number->string (getuid))))
+ (else "/var/run")))
+
+(define (persistent-ssh-pid-file-path config)
+ "Returns a string defining the path to the pid file of a persistent
+ssh connection service, configurable by CONFIG, configurable by CONFIG,
+a record of the <ssh-connection-configuration> type."
+ (string-append (persistent-ssh-pid-folder config)
+ "/"
+ (symbol->string (persistent-ssh-name config))
+ ".pid"))
+
+(define (persistent-ssh-log-folder config)
+ "Returns a string defining the path to the folder in which the log
+file of a persistent ssh connection service is stored by default,
+configurable by CONFIG, a record of the <ssh-connection-configuration>
+type."
+ (cond ((ssh-connection-configuration-log-folder-override? config)
+ (ssh-connection-configuration-log-folder-override config))
+ ((ssh-connection-configuration-elogind? config)
+ (string-append "/run/user/" (number->string (getuid))))
+ (else "/var/run")))
+
+(define (persistent-ssh-log-file-path config)
+ "Returns a string defining the path to the log file of a persistent
+ssh connection service, configurable by CONFIG, a record of the
+<ssh-connection-configuration> type."
+ (string-append (persistent-ssh-log-folder config)
+ "/"
+ (symbol->string (persistent-ssh-name config))
+ ".log"))
+
+(define (persistent-ssh-local-command config)
+ "Returns a string defining command executed locally after the forwards
+of a persistent ssh connection service have been succesfully created,
+configurable by CONFIG, a record of the <ssh-connection-configuration>
+type."
+ (let ((procps-package (ssh-connection-configuration-procps-package config))
+ (clear-password? (ssh-connection-configuration-clear-password?
+ config))
+ (extra-local-commands
+ (ssh-connection-configuration-extra-local-commands
+ config)))
+ (append (list (file-append procps-package
+ "/bin/ps")
+ " --no-header --pid $PPID -o "
+ (if clear-password?
+ "ppid"
+ "pid")
+ " > "
+ (persistent-ssh-pid-file-path config))
+ (map (lambda (command)
+ (string-append " && "
+ command))
+ extra-local-commands))))
+
+(define (persistent-ssh-requires config)
+ "Returns a list of symbols defining the other services required as
+dependencies by the shepherd service of a persistent ssh connection,
+configurable by CONFIG, a record of the <ssh-connection-configuration>
+type."
+ (let* ((req-net? (ssh-connection-configuration-require-networking? config))
+ (extra-reqs (ssh-connection-configuration-extra-requires config))
+ (socks-rec (ssh-connection-configuration-socks-proxy-config config))
+ (inferior? (socks-proxy-configuration-extend? socks-rec))
+ (inferior-cnf (socks-proxy-configuration-dynamic-forward socks-rec))
+ (use-socks? (socks-proxy-configuration-use-proxy? socks-rec))
+ (socks-port (socks-proxy-configuration-port socks-rec))
+ (socks-port-str (number->string socks-port))
+ (flat? (ssh-connection-configuration-flat-force-resurrect? config)))
+ (append
+ (if req-net?
+ (list 'networking)
+ (list))
+ extra-reqs
+ (if inferior?
+ (list (persistent-ssh-name inferior-cnf))
+ (if use-socks?
+ (list (string->symbol
+ ;; FIXME: this just assumes a possible
+ ;; default name, not always true and not
+ ;; even the only possible default.
+ (string-append "ssh-forwards_dynamic@"
+ (number->string socks-port))))
+ (list))))))
+
+(define (persistent-ssh-timeout config)
+ "Returns an integer setting the pid file timout of the shepherd
+service daemonizing a persistent ssh connection, configurable by CONFIG,
+a record of the <ssh-connection-configuration> type."
+ (if (ssh-connection-configuration-timeout-override? config)
+ (ssh-connection-configuration-timeout-override config)
+ #~(+ #$(ssh-connection-configuration-connection-attempts config)
+ (default-pid-file-timeout))))
+
+(define (persistent-ssh-constructor-gexp config)
+ "Returns G-exp to a procedure starting the ssh client process of a
+persistent ssh connection, configurable by CONFIG, a record of the
+<ssh-connection-configuration> type."
+ (let* ((sshpass-pkg (ssh-connection-configuration-sshpass-package config))
+ (password (ssh-connection-configuration-sshd-user-password config))
+ (ssh-pkg (ssh-connection-configuration-ssh-package config))
+ (netcat-pkg (ssh-connection-configuration-netcat-package config))
+ (verbosity (ssh-connection-configuration-verbosity config))
+ (eff? (ssh-connection-configuration-exit-forward-failure? config))
+ (tries (ssh-connection-configuration-connection-attempts config))
+ (tries-str (number->string tries))
+ (local-com? (ssh-connection-configuration-local-command? config))
+ (local-com (persistent-ssh-local-command config))
+ (gateway? (ssh-connection-configuration-gateway-ports? config))
+ (socks-rec (ssh-connection-configuration-socks-proxy-config config))
+ (use-socks? (socks-proxy-configuration-use-proxy? socks-rec))
+ (socks-port (socks-proxy-configuration-port socks-rec))
+ (socks-port-str (number->string socks-port))
+ (command? (ssh-connection-configuration-command? config))
+ (command (ssh-connection-configuration-command config))
+ (forwards (ssh-connection-configuration-forwards config))
+ (sshd-port (ssh-connection-configuration-sshd-port config))
+ (sshd-port-str (number->string sshd-port))
+ (agent? (ssh-connection-configuration-agent? config))
+ (agent-socket (ssh-connection-configuration-agent-socket config))
+ (id-rsa? (ssh-connection-configuration-id-rsa-file? config))
+ (id-rsa (ssh-connection-configuration-id-rsa-file config))
+ (sshd-user (ssh-connection-configuration-sshd-user config))
+ (sshd-host (ssh-connection-configuration-sshd-host config))
+ (dlf? (ssh-connection-configuration-dedicated-log-file? config))
+ (log-file (persistent-ssh-log-file-path config))
+ (pid-file? (ssh-connection-configuration-pid-file? config))
+ (pid-file (persistent-ssh-pid-file-path config))
+ (timeout (persistent-ssh-timeout config))
+ (special-opt (ssh-connection-configuration-special-options config))
+ (strict-check (ssh-connection-configuration-strict-check config))
+ (kh-files (ssh-connection-configuration-known-hosts-files config))
+ (sa-int (ssh-connection-configuration-server-alive-interval
+ config))
+ (acount-max (ssh-connection-configuration-server-alive-count-max
+ config)))
+ #~(make-forkexec-constructor
+ (append #$(if (ssh-connection-configuration-clear-password? config)
+ #~(list #$(file-append sshpass-pkg "/bin/sshpass")
+ "-p"
+ #$password)
+ #~(list))
+ (list #$(file-append ssh-pkg "/bin/ssh")
+ "-o"
+ "TCPKeepAlive=no"
+ "-o"
+ (string-append "ServerAliveInterval="
+ #$(number->string sa-int))
+ "-o"
+ (string-append "ServerAliveCountMax="
+ #$(number->string acount-max))
+ "-o"
+ (string-append "UserKnownHostsFile="
+ #$(string-join kh-files))
+ "-o"
+ (string-append "StrictHostKeyChecking=" #$strict-check)
+ ;; "-o"
+ ;; "Tunnel=point-to-point"
+ "-o"
+ (string-append "ExitOnForwardFailure="
+ #$(if eff?
+ "yes"
+ "no"))
+ "-o"
+ (string-append "ConnectionAttempts="
+ #$tries-str))
+ #$(if local-com?
+ #~(list "-o"
+ "PermitLocalCommand=yes"
+ "-o"
+ (apply string-append
+ (append (list "LocalCommand=")
+ #$(append (list 'list)
+ local-com))))
+ #~(list))
+ #$(if gateway?
+ #~(list "-o"
+ "GatewayPorts=yes")
+ #~(list))
+ #$(if use-socks?
+ #~(list "-o"
+ (string-append "ProxyCommand="
+ #$netcat-pkg
+ "/bin/nc"
+ " -X 5 -x localhost:"
+ #$socks-port-str
+ " %h %p"))
+ #~(list))
+ #$(append (list 'list)
+ special-opt)
+ (list "-p"
+ #$sshd-port-str)
+ #$(if id-rsa?
+ #~(list "-i"
+ #$id-rsa)
+ #~(list))
+ #$(cond ((= verbosity 0) #~(list))
+ ((= verbosity 1) #~(list "-v"))
+ ((= verbosity 2) #~(list "-v" "-v"))
+ ((= verbosity 3) #~(list "-v" "-v" "-v"))
+ (#t #f))
+ #$(if command?
+ #~(list)
+ #~(list "-N"))
+ #$(append (list 'list)
+ (apply append
+ (map persistent-ssh-forward
+ forwards)))
+ (list (string-append #$sshd-user
+ "@"
+ #$sshd-host))
+ #$(if command?
+ #~(list #$command)
+ #~(list)))
+ #:log-file
+ #$(if dlf?
+ log-file
+ #f)
+ #:pid-file
+ #$(if pid-file?
+ pid-file
+ #f)
+ #:pid-file-timeout
+ #$timeout
+ #:environment-variables
+ '#$(if agent?
+ (list (string-append "SSH_AUTH_SOCK="
+ agent-socket))
+ (list (string-append "SSH_AUTH_SOCK="
+ "/dev/null"))))))
+
+(define (persistent-ssh-resurrect-action config)
+ "Returns a G-exp to a procedure used as the procedure of the
+'resurrect action of the shepherd service supporting a persistent ssh
+connection , configurable by CONFIG, a record of the
+<ssh-connection-configuration> type."
+ (let* ((name (persistent-ssh-name config))
+ (socks-rec (ssh-connection-configuration-socks-proxy-config config))
+ (inferior? (socks-proxy-configuration-extend? socks-rec))
+ (inferior-cnf (socks-proxy-configuration-dynamic-forward socks-rec))
+ (use-socks? (socks-proxy-configuration-use-proxy? socks-rec))
+ (socks-port (socks-proxy-configuration-port socks-rec))
+ (socks-port-str (number->string socks-port))
+ (flat? (ssh-connection-configuration-flat-resurrect? config)))
+ #~(lambda (running)
+ (unless (service-running? (lookup-service '#$name))
+ (perform-service-action (lookup-service '#$name)
+ 'enable)
+ (unless (or #$flat?
+ (and (not #$inferior?)
+ (not #$use-socks?)))
+ (let ((inferior-name
+ '#$(if inferior?
+ (persistent-ssh-name inferior-cnf)
+ (if use-socks?
+ (string->symbol
+ ;; FIXME: this just assumes a possible
+ ;; default name, not always true and not
+ ;; even the only possible default.
+ (string-append "ssh-forwards_dynamic@"
+ socks-port-str))
+ 'not-a-service))))
+ (perform-service-action (lookup-service inferior-name)
+ 'resurrect)))
+ (start-service (lookup-service '#$name)))
+ #t)))
+
+(define (persistent-ssh-force-resurrect-action config)
+ "Returns a G-exp to a procedure used as the procedure of the
+'force-resurrect action of the shepherd service supporting a persistent
+ssh connection , configurable by CONFIG, a record of the
+<ssh-connection-configuration> type."
+ (let* ((name (persistent-ssh-name config))
+ (socks-rec (ssh-connection-configuration-socks-proxy-config config))
+ (inferior? (socks-proxy-configuration-extend? socks-rec))
+ (inferior-cnf (socks-proxy-configuration-dynamic-forward socks-rec))
+ (use-socks? (socks-proxy-configuration-use-proxy? socks-rec))
+ (socks-port (socks-proxy-configuration-port socks-rec))
+ (socks-port-str (number->string socks-port))
+ (flat? (ssh-connection-configuration-flat-force-resurrect? config)))
+ #~(lambda (running)
+ (perform-service-action (lookup-service '#$name)
+ 'enable)
+ (stop-service (lookup-service '#$name))
+ (unless (or #$flat?
+ (and (not #$inferior?)
+ (not #$use-socks?)))
+ (let ((inferior-name
+ '#$(if inferior?
+ (persistent-ssh-name inferior-cnf)
+ (if use-socks?
+ (string->symbol
+ ;; FIXME: this just assumes a possible
+ ;; default name, not always true and not
+ ;; even the only possible default.
+ (string-append "ssh-forwards_dynamic@"
+ socks-port-str))
+ 'not-a-service))))
+ (perform-service-action (lookup-service inferior-name)
+ 'force-resurrect)))
+ (start-service (lookup-service '#$name))
+ #t)))
+
+(define (persistent-ssh-shepherd-services config)
+ "Returns a list of shepherd services handling a ssh client daemon
+connection, configured by CONFIG, a record of the
+<ssh-connection-configuration> type."
+ (let* ((name (persistent-ssh-name config))
+ (socks-rec (ssh-connection-configuration-socks-proxy-config config))
+ (inferior? (socks-proxy-configuration-extend? socks-rec))
+ (inferior-cnf (socks-proxy-configuration-dynamic-forward socks-rec))
+ (use-socks? (socks-proxy-configuration-use-proxy? socks-rec))
+ (socks-port (socks-proxy-configuration-port socks-rec))
+ (socks-port-str (number->string socks-port))
+ (reqs (persistent-ssh-requires config))
+ (constructor-gexp (persistent-ssh-constructor-gexp config))
+ (res-gexp (persistent-ssh-resurrect-action config))
+ (force-res-gexp (persistent-ssh-force-resurrect-action config))
+ (auto-start? (ssh-connection-configuration-auto-start? config)))
+ (append
+ (if inferior?
+ (persistent-ssh-shepherd-services inferior-cnf)
+ (list))
+ (list
+ (shepherd-service
+ (documentation "Persistent ssh client connection")
+ (provision `(,name))
+ (requirement reqs)
+ (start constructor-gexp)
+ (stop #~(make-kill-destructor))
+ (actions
+ (list
+ (shepherd-action (name 'resurrect)
+ (documentation
+ "Resurrect this connection and its
+inferiors-proxies if they are stopped or disabled by the Shepherd.")
+ (procedure res-gexp))
+ (shepherd-action (name 'force-resurrect)
+ (documentation "Enable, stop and restart this
+connection and its inferior-proxies , regardless of their current
+status.")
+ (procedure force-res-gexp))))
+ (auto-start? auto-start?))))))
+
+(define (persistent-ssh-cron-jobs config)
+ "Returns a list of cron job specifications to extend the mcron service
+with scheduled resurrection actions on the persistent ssh connection
+port forwards configured by CONFIG, a record of the
+<ssh-connection-configuration> type."
+ (let* ((service-name-str (symbol->string (persistent-ssh-name config)))
+ (lieutenant? (ssh-connection-configuration-lieutenant? config))
+ (lieutenant-path (ssh-connection-configuration-lieutenant-path
+ config))
+ (lieutenant-socket (lieutenant-path->socket-file-path
+ lieutenant-path))
+ (shepherd-pkg
+ (ssh-connection-configuration-shepherd-package config))
+ (cron-resurrect?
+ (ssh-connection-configuration-cron-resurrect? config))
+ (resurrect-time-spec
+ (ssh-connection-configuration-resurrect-time-spec config))
+ (cron-force-resurrect?
+ (ssh-connection-configuration-cron-force-resurrect? config))
+ (force-resurrect-time-spec
+ (ssh-connection-configuration-force-resurrect-time-spec config)))
+ (append
+ (if cron-resurrect?
+ (list #~(job #$resurrect-time-spec
+ (lambda ()
+ (apply execl
+ (append (list (string-append #$shepherd-pkg
+ "/bin/herd")
+ "herd")
+ (if #$lieutenant?
+ (list "-s"
+ #$lieutenant-socket)
+ (list))
+ (list "resurrect"
+ #$service-name-str))))
+ (string-append "resurrect "
+ #$service-name-str)))
+ (list))
+ (if cron-force-resurrect?
+ (list #~(job #$force-resurrect-time-spec
+ (lambda ()
+ (apply execl
+ (append (list (string-append #$shepherd-pkg
+ "/bin/herd")
+ "herd")
+ (if #$lieutenant?
+ (list "-s"
+ #$lieutenant-socket)
+ (list))
+ (list "force-resurrect"
+ #$service-name-str))))
+ (string-append "force-resurrect "
+ #$service-name-str)))
+ (list)))))
+
+(define (persistent-ssh-log-rotation config)
+ "Returns a list of log-rotation records specifying how to rotate the
+logs of a persistent ssh connection configurable by CONFIG, a record of
+the <ssh-connection-configuration> type."
+ (if (and (ssh-connection-configuration-dedicated-log-file? config)
+ (ssh-connection-configuration-log-rotate? config))
+ (list
+ (log-rotation (frequency 'daily)
+ (files `(,(persistent-ssh-log-file-path config)))))
+ (list)))
+
+(define persistent-ssh-service-type
+ (service-type
+ (name 'persistent-ssh)
+ (description "Persistent ssh connection service")
+ (extensions
+ (list (service-extension shepherd-root-service-type
+ persistent-ssh-shepherd-services)
+ (service-extension mcron-service-type
+ persistent-ssh-cron-jobs)
+ (service-extension rottlog-service-type
+ persistent-ssh-log-rotation)
+ (service-extension
+ profile-service-type
+ (lambda (config)
+ (list
+ ssh-tunneler-doc
+ (ssh-connection-configuration-ssh-package config)
+ (ssh-connection-configuration-netcat-package config)
+ (ssh-connection-configuration-sshpass-package config)
+ (ssh-connection-configuration-procps-package config)
+ (ssh-connection-configuration-inetutils-package config)
+ ssh-tunneler-tests)))))
+ (default-value (ssh-connection-configuration))))
+
+(define home-persistent-ssh-service-type
+ (service-type
+ (name 'persistent-ssh)
+ (description "Persistent ssh connection normal user service")
+ (extensions
+ (list (service-extension home-shepherd-service-type
+ persistent-ssh-shepherd-services)
+ (service-extension
+ home-profile-service-type
+ (lambda (config)
+ (list
+ ssh-tunneler-doc
+ (ssh-connection-configuration-ssh-package config)
+ (ssh-connection-configuration-netcat-package config)
+ (ssh-connection-configuration-sshpass-package config)
+ (ssh-connection-configuration-procps-package config)
+ (ssh-connection-configuration-inetutils-package config))
+ ssh-tunneler-tests))))
+ (default-value (ssh-connection-configuration))))
diff --git a/whispers/services/whispers.scm b/whispers/services/whispers.scm
new file mode 100644
index 0000000..bd2d7f5
--- /dev/null
+++ b/whispers/services/whispers.scm
@@ -0,0 +1,792 @@
+;;; Whispers --- Stealth VPN and ssh tunneler
+;;; Copyright © 2023 Runciter <runciter@whispers-vpn.org>
+;;;
+;;; This file is part of Whispers.
+;;;
+;;; Whispers 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.
+;;;
+;;; Whispers 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 Whispers. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (whispers services whispers)
+ #:use-module (guix gexp)
+ #:use-module (guix records)
+ #:use-module (gnu system shadow)
+ #:use-module (gnu services)
+ #:use-module (gnu services shepherd)
+ #:use-module (gnu services mcron)
+ #:use-module (gnu services admin)
+ #:use-module (gnu packages base)
+ #:use-module (gnu packages linux)
+ #:use-module (gnu packages networking)
+ #:use-module (whispers packages whispers)
+ #:use-module (srfi srfi-1)
+ #:export (whispers-configuration
+ whispers-configuration?
+ whispers-user-group
+ whispers-user-group?
+ whispers-user-group-user
+ whispers-user-group-group
+ user-container-name
+ lieutenant-path->socket-file-path
+ whispers-service-type))
+
+(define-record-type* <whispers-configuration>
+ whispers-configuration make-whispers-configuration
+ whispers-configuration?
+ this-whispers-configuration
+ ;; A file-like-object
+ (coreutils-package whispers-configuration-coreutils-package
+ (default coreutils))
+ ;; A file-like-object
+ (util-linux-package whispers-configuration-util-linux-package
+ (default util-linux))
+ ;; A file-like-object
+ (whispers-package whispers-configuration-whispers-package
+ (default whispers))
+ ;; A symbol
+ (name whispers-configuration-name
+ (default 'whispers))
+ ;; A list of guix service objects
+ (lieutenants whispers-configuration-lieutenants
+ (default '()))
+ ;; A list of symbols
+ (requires whispers-configuration-requires
+ (default '()))
+ ;; A string
+ (user whispers-configuration-user
+ (default "root"))
+ ;; A boolean value
+ (extend-user? whispers-configuration-extend-user?
+ (default #f))
+ ;; A string
+ (group whispers-configuration-group
+ (default "root"))
+ ;; A boolean value
+ (extend-group? whispers-configuration-extend-group?
+ (default #f))
+ ;; A string
+ (timeout whispers-configuration-timeout
+ (default '(default-pid-file-timeout)))
+ ;; A list of package objects
+ (extra-packages whispers-configuration-extra-packages
+ (default (list)))
+ ;; A list of shepherd-action records
+ (extra-actions whispers-configuration-extra-actions
+ (default (list)))
+ ;; A boolean value
+ (pre-start-action? whispers-configuration-pre-start-action?
+ (default #f))
+ ;; A boolean value
+ (post-stop-action? whispers-configuration-post-stop-action?
+ (default #f))
+ ;; A boolean value
+ (%auto-start? whispers-configuration-auto-start?
+ (default #t)))
+
+(define-record-type* <whispers-user-group>
+ whispers-user-group make-whispers-user-group
+ whispers-user-group?
+ this-whispers-user-group
+ ;; A string
+ (user whispers-user-group-user
+ (default "johndoe"))
+ ;; A string
+ (group whispers-user-group-group
+ (default "loner")))
+
+(define (user-container-name user)
+ "Return the string \"root-user\" if the string USER is equal to
+\"root\", return the string USER otherwise. This is exported to other
+modules as a dirty ad-hoc convenience function, for use by modules which
+extend a sub-tree whose first branching is done on a per-handle basis."
+ (if (equal? user "root")
+ "root-user"
+ user))
+
+(define (lieutenant-path->socket-file-path lieutenant-path)
+ "Returns as a string the expected path to the socket of the whispers
+lieutenant shepherd at the whispers path defined by the string
+LIEUTENANT-PATH. This is exported to other modules as a dirty ad-hoc
+convenience function."
+ (string-append "/run/whispers"
+ lieutenant-path
+ "/unix-sockets/"
+ (last (string-split lieutenant-path
+ #\/))
+ ".sock"))
+
+(define (shepherd-service-lieutenate parent-path
+ parent-user
+ parent-group
+ config)
+ "Message-passing along the strings PARENT-USER and PARENT-GROUP and
+configurable by CONFIG, a record of the <whispers-configuration> type,
+returns a one argument procedure taking a root shepherd service
+extension as its single parameter and returning a <shepherd-service>
+type guix records for a shepherd service of a lieutenant of a whispers
+service at the top of a whispers tree or sub-tree, as defined by the
+string PARENT-PATH."
+ (lambda (extension)
+ (if (whispers-configuration? config)
+ ((whispers-shepherd-tree parent-path
+ parent-user
+ parent-group) config)
+ ((service-extension-compute extension) config))))
+
+(define (shepherd-services-lieutenate parent-path parent-user parent-group)
+ "Message-passing along the strings PARENT-USER and PARENT-GROUP,
+returns a one argument procedure taking a record of the
+<whispers-configuration> type and returning a list of <shepherd-service>
+type guix records for the lieutenants of a whispers service at the top
+of a whispers tree or sub-tree, as defined by the string PARENT-PATH."
+ (lambda (lieutenant)
+ (map (shepherd-service-lieutenate parent-path
+ parent-user
+ parent-group
+ (service-value lieutenant))
+ (filter (lambda (extension)
+ (equal? (service-extension-target extension)
+ shepherd-root-service-type))
+ (service-type-extensions (service-kind lieutenant))))))
+
+(define (lieutenants-list parent-path
+ parent-user
+ parent-group
+ config)
+ (apply append
+ (apply append
+ (map (shepherd-services-lieutenate parent-path
+ parent-user
+ parent-group)
+ (whispers-configuration-lieutenants config)))))
+
+(define (shepherd-configuration-file parent-path
+ parent-user
+ parent-group
+ config)
+ "Returns a guix store shepherd configuration file for a whispers
+shepherd service at the root of a whispers tree or sub-tree, as defined
+by the string PARENT-PATH, message-passing along the strings PARENT-USER
+and PARENT-PATH, configurable by CONFIG, a record of the
+<whispers-configuration> type."
+ ;; copied and modified from guix's gnu/services/shepherd.scm
+ (let* ((lieutenants (lieutenants-list parent-path
+ parent-user
+ parent-group
+ config))
+ (files (map shepherd-service-file lieutenants)))
+ (define shepherd-config
+ #~(begin (unless (null? '#$files)
+ (apply register-services (map load '#$files)))
+ (map apply
+ (map (lambda whatever start-in-the-background)
+ '#$(map shepherd-service-provision
+ (filter shepherd-service-auto-start?
+ lieutenants)))
+ '#$(map list (map shepherd-service-provision
+ (filter shepherd-service-auto-start?
+ lieutenants))))))
+ (scheme-file (string-append
+ (symbol->string (whispers-configuration-name config))
+ ".conf")
+ shepherd-config)))
+
+(define (whispers-shepherd-tree parent-path parent-user parent-group)
+ "Returns a list of one <shepherd-service> type guix record defining
+the shepherd service at the top of a shepherd tree of sub-tree, equipped
+with a shepherd configuration file defining shepherd services for the
+lieutenants of the returned serivce.
+
+It takes the following parameters:
+ - The string PARENT-PATH is the location of the shepherd service
+daemonizing the returned whispers service in the top-level whispers tree
+of the OS.
+ - The string PARENT-USER is the user name of the user as which runs the
+shepherd service daemonizing the returned whispers service in the
+top-level whispers tree of the OS.
+ - The string PARENT-GROUP is the group name of the group as which runs
+the shepherd service daemonizing the returned whispers service in the
+top-level whispers tree of the OS."
+ (lambda (config)
+ (list
+ (let* ((name-sym (whispers-configuration-name config))
+ (name-str (symbol->string name-sym))
+ (user (whispers-configuration-user config))
+ (group (whispers-configuration-group config))
+ (timeout (whispers-configuration-timeout config))
+ (lieutenants (lieutenants-list parent-path
+ parent-user
+ parent-group
+ config))
+ (lieutenants-names-sym (map car
+ (map shepherd-service-provision
+ lieutenants)))
+ (lieutenants-names-str (map symbol->string
+ lieutenants-names-sym))
+ (lieutenants-path (string-append parent-path
+ name-str
+ "/"))
+ (requires (whispers-configuration-requires config))
+ (parent-runtime-dir (string-append "/run"
+ parent-path))
+ (runtime-dir (string-append parent-runtime-dir
+ name-str))
+ (pid-file (string-append runtime-dir
+ "/"
+ name-str
+ ".pid"))
+ (unix-socket-dir (string-append runtime-dir
+ "/"
+ "unix-sockets"))
+ (unix-socket (string-append unix-socket-dir
+ "/"
+ name-str
+ ".sock"))
+ (superior-runtime-dir (dirname parent-runtime-dir))
+ (superior-unix-socket-dir (string-append superior-runtime-dir
+ "/"
+ "unix-sockets"))
+ (superior-unix-socket (string-append superior-unix-socket-dir
+ "/"
+ (basename
+ superior-runtime-dir)
+ ".sock"))
+ (parent-log-dir (string-append "/var/log"
+ parent-path))
+ (log-dir (string-append parent-log-dir
+ name-str))
+ (log-file (string-append log-dir
+ "/"
+ name-str
+ ".log"))
+ (echo-package (whispers-configuration-coreutils-package config))
+ (rmdir-package echo-package)
+ (mount-pkg (whispers-configuration-util-linux-package config))
+ (pre-start? (whispers-configuration-pre-start-action? config))
+ (post-stop? (whispers-configuration-post-stop-action? config))
+ (extra-actions (whispers-configuration-extra-actions config)))
+ (shepherd-service
+ (documentation "Shepherd controllable from the root shepherd.")
+ (provision `(,name-sym))
+ (requirement requires)
+ (modules (append '((shepherd comm)
+ (shepherd support)
+ (ice-9 match)
+ (ice-9 ftw)
+ (ice-9 regex))
+ %default-modules))
+ (start #~(lambda whatever
+ (perform-service-action (lookup-service '#$name-sym)
+ 'make-tmpfs
+ #$runtime-dir
+ #$user
+ #$group
+ #$(number->string #o755 8))
+ (perform-service-action (lookup-service '#$name-sym)
+ 'make-tmpfs
+ #$unix-socket-dir
+ #$user
+ #$group
+ #$(number->string #o700 8))
+ (perform-service-action (lookup-service '#$name-sym)
+ 'make-directory
+ #$log-dir
+ #$user
+ #$group
+ #$(number->string #o755 8))
+ (when (file-exists? #$unix-socket)
+ (delete-file #$unix-socket))
+ (when #$pre-start?
+ (perform-service-action (lookup-service '#$name-sym)
+ 'pre-start))
+ ((make-forkexec-constructor
+ (list "/run/current-system/profile/bin/shepherd"
+ (string-append
+ "--config="
+ #$(shepherd-configuration-file lieutenants-path
+ user
+ group
+ config))
+ (string-append "--pid="
+ #$pid-file)
+ "-l"
+ #$log-file
+ "-s"
+ #$unix-socket)
+ #:user #$(if (equal? user parent-user)
+ #f
+ user)
+ #:group #$(if (equal? group parent-group)
+ #f
+ group)
+ #:pid-file #$pid-file
+ #:pid-file-timeout #$timeout))))
+ (actions
+ (append
+ extra-actions
+ (list
+ (shepherd-action
+ (name 'make-directory)
+ (documentation "Create a directory at the string PATH
+if it is not exiting. Set the uid of the sting USER, the gid of the
+string GROUP and set the string MODE converted to an octal number as the
+directory's permission bits.")
+ (procedure
+ #~(lambda (running path user group mode)
+ (unless (file-exists? path)
+ (display "Directory ")
+ (display path)
+ (display " not existing, creating.")
+ (display "\n")
+ (mkdir path))
+ (let ((uid (passwd:uid (getpwnam user)))
+ (gid (group:gid (getgrnam group))))
+ (chown path uid gid))
+ (chmod path (string->number mode 8)))))
+ (shepherd-action
+ (name 'make-tmpfs)
+ (documentation "After creating a directory at the mount point if
+necessary, mount a filesystem of type tmpfs at the mount point defined
+by the string PATH if it is not already mounted, owned by the uid of the
+string USER and with group set at the gid of the string GROUP, and mount
+point permissions set to the string MODE taken as an octal number.")
+ (procedure
+ #~(lambda (running path user group mode)
+ (let ((uid (number->string (passwd:uid (getpwnam user))))
+ (gid (number->string (group:gid (getgrnam group)))))
+ (perform-service-action (lookup-service '#$name-sym)
+ 'clear-tmpfs
+ path)
+ (perform-service-action (lookup-service '#$name-sym)
+ 'make-directory
+ path
+ user
+ group
+ mode)
+ ((make-system-constructor
+ #$(file-append mount-pkg "/bin/findmnt")
+ " "
+ path
+ " "
+ "&&"
+ " "
+ #$(file-append echo-package "/bin/echo")
+ " "
+ "tmpfs at"
+ " "
+ path
+ " "
+ "already mounted, aborting make-tmpfs action."
+ " "
+ "||"
+ " "
+ #$(file-append mount-pkg "/bin/mount")
+ " "
+ "-t"
+ " "
+ "tmpfs"
+ " "
+ "-o"
+ " "
+ (string-append "rw,nosuid,nodev,relatime"
+ ",size=1633420k,nr_inodes=408355"
+ ",mode="
+ mode
+ ",uid="
+ uid
+ ",gid="
+ gid)
+ " "
+ "tmpfs"
+ " "
+ path))))))
+ (shepherd-action
+ (name 'subdirs-list)
+ (documentation "Return the list of non-trivial
+subdirectories of the directory whose path is the string PATH.")
+ (procedure
+ #~(lambda (running path)
+ (if (scandir path)
+ (let* ((dir? (lambda (file-name)
+ (equal? 'directory
+ (stat:type (stat file-name)))))
+ (subdir? (lambda (file-name)
+ (and (dir? file-name)
+ (not (equal? file-name
+ (string-append
+ path
+ "/"
+ ".")))
+ (not (equal? file-name
+ (string-append
+ path
+ "/"
+ ".."))))))
+ (absolutes (map string-append
+ (map (lambda (whatever)
+ (string-append path
+ "/"))
+ (scandir path))
+ (scandir path))))
+ (filter subdir? absolutes))
+ '()))))
+ (shepherd-action
+ (name 'clear-tmpfs)
+ (documentation "Unmount a filesystem of type tmpfs at the
+mount point defined by the string PATH if it is mounted. Delete the
+mount point after unmounting.")
+ (procedure
+ #~(lambda (running path)
+ ;; It may be necessary to 'clear-tmpfs down the
+ ;; directory tree when a lieutenant is stopped using its
+ ;; internal stop root action instead of being stopped by
+ ;; its stop action in its controlling shepherd. Possibly
+ ;; also necessary in case a whispers shepherd process
+ ;; unexpectedly dies.
+ (let ((serv-obj (lookup-service '#$name-sym)))
+ (map (lambda (subdir-path)
+ (perform-service-action serv-obj
+ 'clear-tmpfs
+ subdir-path))
+ (perform-service-action serv-obj
+ 'subdirs-list
+ path)))
+ ((make-system-constructor
+ #$(file-append mount-pkg "/bin/findmnt")
+ " "
+ path
+ " "
+ "&&"
+ " "
+ #$(file-append echo-package "/bin/echo")
+ " "
+ "tmpfs at"
+ " "
+ path
+ " "
+ "mounted, proceeding with clear-tmpfs action."
+ " "
+ "&&"
+ " "
+ #$(file-append mount-pkg "/bin/umount")
+ " "
+ "-t"
+ " "
+ "tmpfs"
+ " "
+ path
+ " "
+ "&&"
+ " "
+ #$(file-append rmdir-package "/bin/rmdir")
+ " "
+ path)))))
+ (shepherd-action
+ (name 'socket)
+ (documentation "Return a string containing the path to the
+socket file of the shepherd daemon daemonized by this service.")
+ (procedure
+ #~(lambda (running)
+ #$unix-socket)))
+ (shepherd-action
+ (name 'display-socket)
+ (documentation "Display to standard output a string containing
+the path to the socket file of the shepherd daemon daemonized by this
+service.")
+ (procedure
+ #~(lambda (running)
+ (let ((serv-obj (lookup-service '#$name-sym)))
+ (local-output (perform-service-action serv-obj
+ 'socket))))))
+ (shepherd-action
+ (name 'superior-socket)
+ (documentation "Return a string containing the path to the
+socket file of the shepherd daemon daemonized by the whispers superior
+of this service.")
+ (procedure
+ #~(lambda (running)
+ #$superior-unix-socket)))
+ (shepherd-action
+ (name 'display-superior-socket)
+ (documentation "Display to standard output a string containing
+the path to the socket file of the shepherd daemon daemonized by the
+whispers superior of this service.")
+ (procedure
+ #~(lambda (running)
+ (let ((serv-obj (lookup-service '#$name-sym))
+ (sup 'superior-socket))
+ (local-output (perform-service-action serv-obj
+ sup))))))
+ (shepherd-action
+ (name 'display-load-path)
+ (documentation "For debugging purposes, display the
+guile load path that is enforced in this action's prodedure scope.")
+ (procedure
+ #~(lambda (running)
+ (display %load-path)
+ (display "\n"))))
+ (shepherd-action
+ (name 'display-load-compiled-path)
+ (documentation "For debugging purposes, display the
+guile compiled load path that is enforced in this action's prodedure
+scope.")
+ (procedure
+ #~(lambda (running)
+ (display %load-compiled-path)
+ (display "\n"))))
+ (shepherd-action
+ (name 'display-lieutenant-action)
+ (documentation "Perform the action named by the string
+ACTION-STR of the service providing the string SERVICE-STR of the
+shepherd daemon daemonized by this whispers service. The arguement
+strings ARGS are passed to the action. For debugging purposes, display
+the return value of the aforementioned lieutenant service's action.")
+ (procedure
+ #~(lambda (running action-str service-str . args)
+ (display (apply perform-service-action
+ (append (list '#$name-sym
+ 'lieutenant-action
+ action-str
+ service-str)
+ args)))
+ (display "\n"))))
+ ;; FIXME?: there's problems with this? Maybe risky.
+ (shepherd-action
+ (name 'lieutenant-action)
+ (documentation "Perform the action named by the string
+ACTION-STR of the service providing the string SERVICE-STR of the
+shepherd daemon daemonized by this whispers service. The arguement
+strings ARGS are passed to the action. Return the return value of
+the aforementioned lieutenant service's action.")
+ (procedure
+ #~(lambda (running action-str service-str . args)
+ ;; inspired by (shepherd scripts herd).
+ (define lieutenant-port
+ (let ((serv-obj (lookup-service '#$name-sym)))
+ (open-connection (perform-service-action serv-obj
+ 'socket))))
+ (let ((action-sym (string->symbol action-str))
+ (service-sym (string->symbol service-str)))
+ (write-command (shepherd-command action-sym
+ service-sym
+ #:arguments
+ args)
+ lieutenant-port))
+ (define ret
+ (match (read lieutenant-port)
+ (('reply ('version 0)
+ ('result result) ('error #f)
+ ('messages messages))
+ (unless (null? messages)
+ (for-each (lambda (message)
+ (display message)
+ (display "\n"))
+ messages))
+ (if (pair? result)
+ (car result)
+ #f))))
+ (close-port lieutenant-port)
+ ret)))
+ ;; FIXME: do not use: bad hangs (bidirectional communication?)
+ (shepherd-action
+ (name 'superior-action)
+ (documentation "Perform the action named by the string
+ACTION-STR of the service providing the string SERVICE-STR of the
+shepherd daemon daemonizing the shepherd daemon of the whispers superior
+of this whispers service. The arguement strings ARGS are passed to the
+action. Return the return value of the aforementioned superior shepherd's
+action.")
+ (procedure
+ #~(lambda (running action-str service-str . args)
+ ; inspired by (shepherd scripts herd)
+ (define superior-port
+ (open-connection (car (perform-service-action
+ (lookup-service '#$name-sym)
+ 'superior-socket))))
+ (let ((action-sym (string->symbol action-str))
+ (service-sym (string->symbol service-str)))
+ (write-command (shepherd-command action-sym
+ service-sym
+ #:arguments
+ args)
+ superior-port))
+ (define ret
+ (match (read superior-port)
+ (('reply ('version 0)
+ ('result result) ('error #f)
+ ('messages messages))
+ (unless (null? messages)
+ (for-each (lambda (message)
+ (display message)
+ (display "\n"))
+ messages))
+ (if (pair? result)
+ (car result)
+ #f))))
+ (close-port superior-port)
+ ret))))))
+ (stop #~(lambda (pid)
+ (map (lambda (lieutenant-name)
+ (perform-service-action (lookup-service '#$name-sym)
+ 'lieutenant-action
+ "stop"
+ lieutenant-name))
+ '#$lieutenants-names-str)
+ (define ret ((make-kill-destructor) pid))
+ (when #$post-stop?
+ (perform-service-action (lookup-service '#$name-sym)
+ 'post-stop))
+ (perform-service-action (lookup-service '#$name-sym)
+ 'clear-tmpfs
+ #$unix-socket-dir)
+ (perform-service-action (lookup-service '#$name-sym)
+ 'clear-tmpfs
+ #$runtime-dir)
+ ret))
+ (auto-start? (whispers-configuration-auto-start? config)))))))
+
+(define (whispers-service-type? service)
+ "Returns a predicate which is true if SERVICE, a service object, is a
+service of type whispers-service-type"
+ (equal? (service-kind service) whispers-service-type))
+
+(define (whispers-tree-log-files parent-path)
+ "Returns a one argument procedure taking a record of the
+<whispers-configuration> type as its argement and returning the list of
+log files from the whispers-service-type services located under the
+string PARENT-PATH in the whispers service top-level tree or sub-tree
+configured by the aforementioned configuration record."
+ (lambda (config)
+ (let* ((name-sym (whispers-configuration-name config))
+ (name-str (symbol->string name-sym))
+ (lieutenants (whispers-configuration-lieutenants config)))
+ (append `(,(string-append "/var/log"
+ parent-path
+ "/"
+ name-str
+ ".log"))
+ (apply append
+ (map (whispers-tree-log-files (string-append parent-path
+ "/"
+ name-str))
+ (map service-value
+ (filter whispers-service-type?
+ lieutenants))))))))
+
+(define (whispers-log-rotation config)
+ "Returns a record of the <log-rotation> type specifying the log
+rotations of the whispers-service-type type services contained inside
+the whispers tree of a top-level service of the whisper-service-type
+type, configurable by CONFIG, a record of the <whispers-configuration>
+type."
+ (list (log-rotation (frequency 'daily)
+ (files ((whispers-tree-log-files "") config)))))
+
+(define (whispers-user-accounts config)
+ "Returns a list of group and user records needed to support a whispers
+service tree, configuration by CONFIG, a record of the
+<whispers-configuration> type."
+ (let* ((user (whispers-configuration-user config))
+ (extend-user? (whispers-configuration-extend-user? config))
+ (group (whispers-configuration-group config))
+ (extend-group? (whispers-configuration-extend-group? config))
+ (lieutenants (whispers-configuration-lieutenants config))
+ (whispers-lieutenants (filter whispers-service-type? lieutenants)))
+ (append (if extend-group?
+ (list (user-group (name group)
+ (system? #t)))
+ (list))
+ (if extend-user?
+ (list (user-account (name user)
+ (group group)
+ (create-home-directory? #f)
+ (system? #t)))
+ (list))
+ (apply append
+ (map whispers-user-accounts
+ (map service-value
+ whispers-lieutenants))))))
+
+(define (collect-compute-r service-type-target)
+ "Return a one argument procedure taking a service object as its single
+argument and returning a list appending outputs of the compute
+procedures of all the extensions of target SERVICE-TYPE-TARGET from the
+services which are not themselves of type whispers-service-type from a
+whispers top-level tree or sub-tree defined by the service given as its
+argument."
+ (lambda (service)
+ (if (whispers-service-type? service)
+ (let* ((config (service-value service))
+ (lieutenants (whispers-configuration-lieutenants config)))
+ (apply append
+ (map (collect-compute-r service-type-target)
+ lieutenants)))
+ (let* ((kind (service-kind service))
+ (exts (filter (lambda (extension)
+ (equal? (service-extension-target extension)
+ service-type-target))
+ (service-type-extensions kind)))
+ (computes (map service-extension-compute exts)))
+ (apply append
+ (map (lambda (compute)
+ (compute (service-value service)))
+ computes))))))
+
+(define (collect-compute service-type-target)
+ "Return a one argument procedure taking a whispers-configuration type
+guix record as its single argument and returning a list appending
+outputs of the compute procedures of all the extensions of target
+SERVICE-TYPE-TARGET from the services which are not themselves of type
+whispers-service-type from a whispers top-level tree defined by the
+service given as its argument."
+ (lambda (config)
+ (let ((lieutenants (whispers-configuration-lieutenants config)))
+ (apply append (map (collect-compute-r service-type-target)
+ lieutenants)))))
+
+(define whispers-service-type
+ (let ((coreutils-package whispers-configuration-coreutils-package)
+ (util-linux-package whispers-configuration-util-linux-package)
+ (whispers-pkg whispers-configuration-whispers-package)
+ (extra-packages whispers-configuration-extra-packages)
+ (get-lieutenants whispers-configuration-lieutenants))
+ (service-type
+ (name 'whispers)
+ (description "Shepherd process controllable from the root shepherd.")
+ (extensions
+ (list (service-extension shepherd-root-service-type
+ (whispers-shepherd-tree "/" "root" "root"))
+ (service-extension rottlog-service-type
+ whispers-log-rotation)
+ (service-extension account-service-type
+ whispers-user-accounts)
+ (service-extension profile-service-type
+ (lambda (config)
+ (append (list (coreutils-package config)
+ (util-linux-package config)
+ (whispers-pkg config))
+ (extra-packages config))))
+ (service-extension profile-service-type
+ (collect-compute profile-service-type))
+ (service-extension rottlog-service-type
+ (collect-compute rottlog-service-type))
+ (service-extension rottlog-service-type
+ (collect-compute account-service-type))
+ (service-extension mcron-service-type
+ (collect-compute mcron-service-type))))
+ (compose concatenate)
+ (extend (lambda (config lieutenants-new)
+ (whispers-configuration
+ (inherit config)
+ (lieutenants (append (get-lieutenants config)
+ lieutenants-new)))))
+ (default-value (whispers-configuration)))))
diff --git a/whispers/services/whispers/finance.scm b/whispers/services/whispers/finance.scm
new file mode 100644
index 0000000..1ce7e5b
--- /dev/null
+++ b/whispers/services/whispers/finance.scm
@@ -0,0 +1,331 @@
+;;; Whispers --- Stealth VPN and ssh tunneler
+;;; Copyright © 2023 Runciter <runciter@whispers-vpn.org>
+;;;
+;;; This file is part of Whispers.
+;;;
+;;; Whispers 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.
+;;;
+;;; Whispers 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 Whispers. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (whispers services whispers finance)
+ #:use-module (guix gexp)
+ #:use-module (guix records)
+ #:use-module (gnu system shadow)
+ #:use-module (gnu services)
+ #:use-module (gnu services shepherd)
+ #:use-module (whispers services whispers)
+ #:use-module (whispers services finance)
+ #:use-module (gnu packages finance)
+ #:use-module (gnu packages guile)
+ #:use-module (gnu packages linux)
+ #:export (whispers-finance-service-type
+ whispers-finance-configuration
+ whispers-finance-configuration?
+ crypto-user-group-nodes
+ crypto-user-group-nodes?
+ nodes-configuration
+ nodes-configuration?
+ bitcoin-node-configuration
+ bitcoin-node-configuration?
+ monero-node-configuration
+ monero-node-configuration?))
+
+(define-record-type* <whispers-finance-configuration>
+ whispers-finance-configuration make-finance-configuration
+ whispers-finance-configuration?
+ this-whispers-finance-configuration
+ ;; A list of crypto-user-group-nodes records
+ (users-groups-nodes whispers-finance-configuration-users-groups-nodes
+ (default '())))
+
+(define-record-type* <crypto-user-group-nodes>
+ crypto-user-group-nodes make-crypto-user-group-nodes
+ crypto-user-group-nodes?
+ this-crypto-user-group-nodes
+ ;; A whispers-user-group record
+ (user-and-group crypto-user-group-nodes-user-and-group
+ (default (whispers-user-group)))
+ ;; A <nodes-configuration record>
+ (nodes crypto-user-group-nodes-nodes
+ (default '(nodes-configuration))))
+
+(define-record-type* <nodes-configuration>
+ nodes-configuration make-nodes-configuration
+ nodes-configuration?
+ this-nodes-configuration
+ ;; A boolean value.
+ (bitcoin? nodes-configuration-bitcoin?
+ (default #f))
+ ;; A <bitcoin-node-configuration> record
+ (btc-node nodes-configuration-btc-node
+ (default (bitcoin-node-configuration)))
+ ;; A boolean value
+ (monero? nodes-configuration-monero?
+ (default #f))
+ ;; A <monero-node-configuration> record
+ (xmr-node nodes-configuration-xmr-node
+ (default (monero-node-configuration))))
+
+(define-record-type* <bitcoin-node-configuration>
+ bitcoin-node-configuration make-bitcoin-node-configuration
+ bitcoin-node-configuration?
+ this-bitcoin-node-configuration
+ ;; A file-like object
+ (bitcoin-package bitcoin-node-configuration-bitcoin-package
+ (default bitcoin-core))
+ ;; A boolean value
+ (walletdir-opt? bitcoin-node-configuration-walletdir-opt?
+ (default #f))
+ ;; A string
+ (walletdir bitcoin-node-configuration-walletdir
+ (default ""))
+ ;; A boolean value
+ (proxy-opt? bitcoin-node-configuration-proxy-opt?
+ (default #f))
+ ;; A string
+ (proxy bitcoin-node-configuration-proxy
+ (default ""))
+ ;; A boolean value
+ (%auto-start? bitcoin-node-configuration-auto-start?
+ (default #t)))
+
+(define-record-type* <monero-node-configuration>
+ monero-node-configuration make-monero-node-configuration
+ monero-node-configuration?
+ this-monero-node-configuration
+ ;; A file-like object
+ (monero-package monero-node-configuration-monero-package
+ (default monero))
+ ;; A boolean value
+ (proxy-opt? monero-node-configuration-proxy-opt?
+ (default #f))
+ ;; A string
+ (proxy monero-node-configuration-proxy
+ (default ""))
+ ;; A boolean value
+ (tx-proxy-opt? monero-node-configuration-tx-proxy-opt?
+ (default #f))
+ ;; A boolean value
+ (prune-blockchain-opt? monero-node-configuration-prune-blockchain-opt?
+ (default #f))
+ ;; A string
+ (tx-proxy monero-node-configuration-tx-proxy
+ (default ""))
+ ;; A boolean value
+ (%auto-start? monero-node-configuration-auto-start?
+ (default #t)))
+
+(define (log-folder user)
+ "Return a string naming the path to the folder where the log file of
+the bitcoin node daemon of the user named by the string USER is stored."
+ (string-append "/var/log/whispers/finance/"
+ (user-container-name user)
+ "/bitcoin"))
+
+(define (rightwing-log-folder user)
+ "Return a string naming the path to the folder where the log file of
+the monero node daemon of the user named by the string USER is stored."
+ (string-append "/var/log/whispers/finance/"
+ (user-container-name user)
+ "/monero"))
+
+(define (pid-folder user)
+ "Return a string naming the path to the folder where the pid file of
+the bitcoin node daemon of the user named by the string USER is
+located."
+ (string-append "/run/whispers/finance/"
+ (user-container-name user)
+ "/bitcoin"))
+
+(define (rightwing-pid-folder user)
+ "Return a string naming the path to the folder where the pid file of
+the monero node daemon of the user named by the string USER is
+located."
+ (string-append "/run/whispers/finance/"
+ (user-container-name user)
+ "/monero"))
+
+(define (btc-node user wal)
+ "Returns a bitcoin node guix service for a bitcoin node daemon from
+the package BITCOIN-PACKAGE owned by the user named by the string USER
+and with the wallet parameters configured by WAL, a record of the
+<bitcoin-node-configuration> type."
+ (let ((bitcoin-package (bitcoin-node-configuration-bitcoin-package wal))
+ (walletdir-opt? (bitcoin-node-configuration-walletdir-opt? wal))
+ (walletdir (bitcoin-node-configuration-walletdir wal))
+ (proxy-opt? (bitcoin-node-configuration-proxy-opt? wal))
+ (proxy (bitcoin-node-configuration-proxy wal))
+ (auto-start? (bitcoin-node-configuration-auto-start? wal)))
+ (service
+ bitcoin-service-type
+ (bitcoin-configuration (bitcoin-package bitcoin-package)
+ (user user)
+ (log-folder (log-folder user))
+ (pid (string-append (pid-folder user)
+ "/"
+ "bitcoin.pid"))
+ (walletdir-opt? walletdir-opt?)
+ (walletdir walletdir)
+ (proxy-opt? proxy-opt?)
+ (proxy proxy)
+ (%auto-start? auto-start?)))))
+
+(define (rightwing-node user node)
+ "Returns a monero node guix service for a monero node daemon from the
+package MONERO-PACKAGE owned by the user named by the string USER and
+with the node parameters configured by NODE, a record of the
+<monero-node-configuration> type."
+ (let ((monero-package (monero-node-configuration-monero-package node))
+ (proxy-opt? (monero-node-configuration-proxy-opt? node))
+ (proxy (monero-node-configuration-proxy node))
+ (tx-proxy-opt? (monero-node-configuration-tx-proxy-opt? node))
+ (tx-proxy (monero-node-configuration-tx-proxy node))
+ (prune? (monero-node-configuration-prune-blockchain-opt? node))
+ (auto-start? (monero-node-configuration-auto-start? node)))
+ (service
+ monero-service-type
+ (monero-configuration (monero-package monero-package)
+ (user user)
+ (log-folder (rightwing-log-folder user))
+ (pidfile
+ (string-append (rightwing-pid-folder user)
+ "/"
+ "monero.pid"))
+ (proxy-opt? proxy-opt?)
+ (proxy proxy)
+ (tx-proxy-opt? tx-proxy-opt?)
+ (tx-proxy tx-proxy)
+ (prune-blockchain-opt? prune?)
+ (%auto-start? auto-start?)))))
+
+(define (extra-actions user group nodes)
+ "Return a list of <shepherd-action> records for the creation and
+destruction of the folders and temporary file systems necessary for the
+operation of the bitcoin node daemon of the user named by the string
+USER, configuration by NODES, a record of the <nodes-configuration>
+type."
+ (let* ((user-str (user-container-name user))
+ (user-sym (string->symbol user-str))
+ (bitcoin? (nodes-configuration-bitcoin? nodes))
+ (monero? (nodes-configuration-monero? nodes)))
+ (list (shepherd-action
+ (name 'pre-start)
+ (documentation "Create the directories and tmpfs mounts
+used by the bitcoin node daemon.")
+ (procedure
+ #~(lambda (running)
+ (unless (not #$bitcoin?)
+ (action '#$user-sym
+ 'make-directory
+ #$(log-folder user-str)
+ #$user
+ #$group
+ #$(number->string #o755 8))
+ (action '#$user-sym
+ 'make-tmpfs
+ #$(pid-folder user)
+ #$user
+ #$group
+ #$(number->string #o755 8)))
+ (unless (not #$monero?)
+ (action '#$user-sym
+ 'make-directory
+ #$(rightwing-log-folder user-str)
+ #$user
+ #$group
+ #$(number->string #o755 8))
+ (action '#$user-sym
+ 'make-tmpfs
+ #$(rightwing-pid-folder user)
+ #$user
+ #$group
+ #$(number->string #o755 8))))))
+ (shepherd-action
+ (name 'post-stop)
+ (documentation "Unmount the tmpfs mounts used by the bitcoin
+node daemon.")
+ (procedure
+ #~(lambda (running)
+ (unless (not #$bitcoin?)
+ (action '#$user-sym
+ 'clear-tmpfs
+ #$(pid-folder user)))
+ (unless (not #$monero?)
+ (action '#$user-sym
+ 'clear-tmpfs
+ #$(rightwing-pid-folder user)))))))))
+
+(define (node-lieutenants user nodes)
+ "Returns a list of zero to two crypto node guix shepherd services
+daemonizing a bitcoin and/or a monero node, running as the user USER,
+and configured by NODES, a record of the <nodes-configuration> type."
+ (let* ((user-str (user-container-name user))
+ (user-sym (string->symbol user-str))
+ (bitcoin? (nodes-configuration-bitcoin? nodes))
+ (bitcoin-node (nodes-configuration-btc-node nodes))
+ (monero? (nodes-configuration-monero? nodes))
+ (monero-node (nodes-configuration-xmr-node nodes)))
+ (append (if bitcoin?
+ (list (btc-node user
+ bitcoin-node))
+ (list))
+ (if monero?
+ (list (rightwing-node user
+ monero-node))
+ (list)))))
+
+
+(define (nodes-lieutenant user group nodes)
+ "Returns an elementary whispers service tree for a single user's
+section of whispers finance sub-tree, at the tip of which a bitcoin node
+daemon and a monero node can be daemonized owned by the user named by
+the string USER and the group named by the string GROUP, with nodes
+configured by NODES, a record of the <nodes-configuration> type."
+ (service whispers-service-type
+ (whispers-configuration (name (string->symbol
+ (user-container-name user)))
+ (lieutenants (node-lieutenants user
+ nodes))
+ (user user)
+ (group group)
+ (pre-start-action? #t)
+ (post-stop-action? #t)
+ (extra-actions (extra-actions user
+ group
+ nodes)))))
+
+(define (whispers-finance-tree config)
+ "Returns a whispers service tree for a whispers bitcoin nodes
+sub-tree, configurable by CONFIG, a record of the
+<whispers-finance-configuration> type."
+ (let* ((ugws (whispers-finance-configuration-users-groups-nodes config))
+ (user-group crypto-user-group-nodes-user-and-group)
+ (user (lambda (ugw) (whispers-user-group-user (user-group ugw))))
+ (group (lambda (ugw) (whispers-user-group-group (user-group ugw))))
+ (nodes (lambda (ugw)
+ (crypto-user-group-nodes-nodes ugw))))
+ (list (service whispers-service-type
+ (whispers-configuration
+ (name 'finance)
+ (lieutenants (map (lambda (ugw)
+ (nodes-lieutenant (user ugw)
+ (group ugw)
+ (nodes ugw)))
+ ugws)))))))
+
+(define whispers-finance-service-type
+ (service-type
+ (name '(whispers-finance))
+ (description "Daemonized per-user cryptocurrency nodes")
+ (extensions (list (service-extension whispers-service-type
+ whispers-finance-tree)))
+ (default-value (whispers-finance-configuration))))
diff --git a/whispers/services/whispers/gps.scm b/whispers/services/whispers/gps.scm
new file mode 100644
index 0000000..2e7f71b
--- /dev/null
+++ b/whispers/services/whispers/gps.scm
@@ -0,0 +1,100 @@
+;;; Whispers --- Stealth VPN and ssh tunneler
+;;; Copyright © 2024 Runciter <runciter@whispers-vpn.org>
+;;;
+;;; This file is part of Whispers.
+;;;
+;;; Whispers 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.
+;;;
+;;; Whispers 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 Whispers. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (whispers services whispers gps)
+ #:use-module (guix records)
+ #:use-module (guix gexp)
+ #:use-module (gnu services)
+ #:use-module (whispers services whispers)
+ #:use-module (whispers services gps)
+ #:use-module (gnu system shadow)
+ #:export (whispers-gps-service-type
+ gps-user-group-configs
+ gps-user-group-configs?))
+
+(define-record-type* <gps-user-group-configs>
+ gps-user-group-configs make-gps-user-group-configs
+ gps-user-group-configs?
+ this-gps-user-group-configs
+ ;; A <whispers-user-group> record
+ (user-and-group gps-user-group-configs-user-and-group
+ (default (whispers-user-group)))
+ ;; A boolean value
+ (gpsd? gps-user-group-configs-gpsd?
+ (default #t))
+ ;; A list of <gpsd-configuration> type records
+ (gpsd-configs gps-user-group-configs-gpsd-configs
+ (default (list (gpsd-configuration)))))
+
+(define (user-lieutenant gpsd?
+ user
+ group
+ gpsd-configs)
+ "Returns a whispers sub-tree for a single user's section of a whispers
+gps sub-tree, owned by the user named by the string USER and the group
+named by the string GROUP, at the tip of which a list gpsd services is
+daemonized when GPSD? evaluates to a true value, configured by
+GPSD-CONFIGS, a list of records of the <gpsd-configuration> type."
+ (service whispers-service-type
+ (whispers-configuration
+ (name (string->symbol (user-container-name user)))
+ (lieutenants
+ (if gpsd?
+ (list (service whispers-service-type
+ (whispers-configuration
+ (name 'gpsd)
+ (lieutenants
+ (map (lambda (config)
+ (service gpsd-service-type
+ config))
+ gpsd-configs))
+ (user user)
+ (group group))))))
+ (user user)
+ (group group))))
+
+(define (whispers-gps-tree configs)
+ "Returns a whispers service tree for a whispers gps sub-tree,
+configurable by CONFIGS, a list of records of the
+<gps-user-group-configs> type."
+ (let* ((user-group gps-user-group-configs-user-and-group)
+ (user (lambda (ugc)
+ (whispers-user-group-user (user-group ugc))))
+ (group (lambda (ugc)
+ (whispers-user-group-group (user-group ugc))))
+ (gpsd? (lambda (ugc)
+ (gps-user-group-configs-gpsd? ugc)))
+ (gpsd-configs (lambda (ugc)
+ (gps-user-group-configs-gpsd-configs ugc))))
+ (list (service whispers-service-type
+ (whispers-configuration
+ (name 'gps)
+ (lieutenants (map (lambda (ugc)
+ (user-lieutenant (gpsd? ugc)
+ (user ugc)
+ (group ugc)
+ (gpsd-configs ugc)))
+ configs)))))))
+
+(define whispers-gps-service-type
+ (service-type
+ (name '(whispers-gps))
+ (description "Per-user gpsd")
+ (extensions (list (service-extension whispers-service-type
+ whispers-gps-tree)))
+ (default-value '())))
diff --git a/whispers/services/whispers/mail.scm b/whispers/services/whispers/mail.scm
new file mode 100644
index 0000000..bd2c177
--- /dev/null
+++ b/whispers/services/whispers/mail.scm
@@ -0,0 +1,174 @@
+;;; Whispers --- Stealth VPN and ssh tunneler
+;;; Copyright © 2024 Runciter <runciter@whispers-vpn.org>
+;;;
+;;; This file is part of Whispers.
+;;;
+;;; Whispers 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.
+;;;
+;;; Whispers 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 Whispers. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (whispers services whispers mail)
+ #:use-module (guix gexp)
+ #:use-module (guix records)
+ #:use-module (gnu system shadow)
+ #:use-module (gnu services)
+ #:use-module (gnu services shepherd)
+ #:use-module (whispers services whispers)
+ #:use-module (whispers services proton)
+ #:use-module (gnu packages mail)
+ #:use-module (gnu packages guile)
+ #:use-module (gnu packages linux)
+ #:export (whispers-mail-service-type
+ whispers-mail-configuration
+ whispers-mail-configuration?
+ mail-user-group-services
+ mail-user-group-services?
+ mail-services-configuration
+ mail-services-configuration?
+ hydroxide-service-configuration
+ hydroxide-service-configuration?))
+
+(define-record-type* <whispers-mail-configuration>
+ whispers-mail-configuration make-whispers-mail-configuration
+ whispers-mail-configuration?
+ this-whispers-mail-configuration
+ ;; A list of mail-user-group-services records
+ (users-groups-services whispers-mail-configuration-users-groups-services
+ (default '())))
+
+(define-record-type* <mail-user-group-services>
+ mail-user-group-services make-mail-user-group-services
+ mail-user-group-services?
+ this-mail-user-group-services
+ ;; A whispers-user-group record
+ (user-and-group mail-user-group-services-user-and-group
+ (default (whispers-user-group)))
+ ;; A <mail-services-configuration record>
+ (services mail-user-group-services-services
+ (default (mail-services-configuration))))
+
+(define-record-type* <mail-services-configuration>
+ mail-services-configuration make-mail-services-configuration
+ mail-services-configuration?
+ this-mail-services-configuration
+ ;; A boolean value.
+ (hydroxide? mail-services-configuration-hydroxide?
+ (default #f))
+ ;; An <hydroxide-configuration> record
+ (hydroxide-service mail-services-configuration-hydroxide-service
+ (default (hydroxid-service-configuration))))
+
+(define-record-type* <hydroxide-service-configuration>
+ hydroxide-service-configuration make-hydroxide-service-configuration
+ hydroxide-service-configuration?
+ this-hydroxide-service-configuration
+ ;; A file-like object
+ (hydroxide-package hydroxide-service-configuration-hydroxide-package
+ (default hydroxide))
+ ;; A boolean value
+ (https-proxy? hydroxide-service-configuration-https-proxy?
+ (default #f))
+ ;; A string
+ (https-proxy hydroxide-service-configuration-https-proxy
+ (default "socks5://localhost:8971"))
+ ;; A boolean value
+ (imap? hydroxide-service-configuration-imap?
+ (default #t))
+ ;; A boolean value
+ (smtp? hydroxide-service-configuration-smtp?
+ (default #t))
+ ;; A boolean value
+ (carddav? hydroxide-service-configuration-carddav?
+ (default #t))
+ ;; A boolean value
+ (%auto-start? hydroxide-service-configuration-auto-start?
+ (default #t)))
+
+(define (proton-service user serv)
+ "Returns an hydroxidce guix service for a server owned by the user named
+by the string USER and with the service parameters configured by serv, a
+record of the <hydroxide-service-configuration> type."
+ (let ((hydroxide-package (hydroxide-service-configuration-hydroxide-package
+ serv))
+ (https-proxy? (hydroxide-service-configuration-https-proxy? serv))
+ (https-proxy (hydroxide-service-configuration-https-proxy serv))
+ (imap? (hydroxide-service-configuration-imap? serv))
+ (smtp? (hydroxide-service-configuration-smtp? serv))
+ (carddav? (hydroxide-service-configuration-carddav? serv))
+ (auto-start? (hydroxide-service-configuration-auto-start? serv)))
+ (service
+ hydroxide-service-type
+ (hydroxide-configuration (hydroxide-package hydroxide-package)
+ (user user)
+ (https-proxy? https-proxy?)
+ (https-proxy https-proxy)
+ (imap? imap?)
+ (smtp? smtp?)
+ (carddav? carddav?)
+ (%auto-start? auto-start?)))))
+
+(define (services-lieutenants user services)
+ "Returns a list of zero to one mail service guix shepherd services
+daemonizing an hydroxide server for localhost , running as the user
+USER, and configured by SERVICES, a record of the
+<mail-services-configuration> type."
+ (let* ((user-str (user-container-name user))
+ (user-sym (string->symbol user-str))
+ (hydroxide? (mail-services-configuration-hydroxide? services))
+ (hydroxide-service (mail-services-configuration-hydroxide-service
+ services)))
+ (if hydroxide?
+ (list (proton-service user
+ hydroxide-service))
+ (list))))
+
+
+(define (mail-lieutenant user group services)
+ "Returns an elementary whispers service tree for a single user's
+section of whispers mail sub-tree, at the tip of which an hydroxide
+server can be daemonized owned by the user named by the string USER and
+the group named by the string GROUP, with services configured by SERVICES, a
+record of the <mail-services-configuration> type."
+ (service whispers-service-type
+ (whispers-configuration (name (string->symbol
+ (user-container-name user)))
+ (lieutenants (services-lieutenants
+ user
+ services))
+ (user user)
+ (group group))))
+
+(define (whispers-mail-tree config)
+ "Returns a whispers service tree for a whispers mail sub-tree,
+configurable by CONFIG, a record of the <whispers-mail-configuration>
+type."
+ (let* ((ugws (whispers-mail-configuration-users-groups-services config))
+ (user-group mail-user-group-services-user-and-group)
+ (user (lambda (ugw) (whispers-user-group-user (user-group ugw))))
+ (group (lambda (ugw) (whispers-user-group-group (user-group ugw))))
+ (services (lambda (ugw) (mail-user-group-services-services ugw))))
+ (list (service whispers-service-type
+ (whispers-configuration
+ (name 'mail)
+ (lieutenants (map (lambda (ugw)
+ (mail-lieutenant (user ugw)
+ (group ugw)
+ (services ugw)))
+ ugws)))))))
+
+(define whispers-mail-service-type
+ (service-type
+ (name '(whispers-mail))
+ (description "Daemonized per-user hydroxide servers")
+ (extensions (list (service-extension whispers-service-type
+ whispers-mail-tree)))
+ (default-value (whispers-mail-configuration))))
diff --git a/whispers/services/whispers/ssh.scm b/whispers/services/whispers/ssh.scm
new file mode 100644
index 0000000..a5ff1d1
--- /dev/null
+++ b/whispers/services/whispers/ssh.scm
@@ -0,0 +1,629 @@
+;;; Whispers --- Stealth VPN and ssh tunneler
+;;; Copyright © 2023 Runciter <runciter@whispers-vpn.org>
+;;;
+;;; This file is part of Whispers.
+;;;
+;;; Whispers 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.
+;;;
+;;; Whispers 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 Whispers. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (whispers services whispers ssh)
+ #:use-module (guix gexp)
+ #:use-module (guix records)
+ #:use-module (gnu system shadow)
+ #:use-module (gnu services)
+ #:use-module (gnu services shepherd)
+ #:use-module (whispers services whispers)
+ #:use-module (whispers services ssh-agent)
+ #:use-module (whispers services ssh-tunneler)
+ #:use-module (gnu packages ssh)
+ #:use-module (gnu packages guile)
+ #:use-module (gnu packages linux)
+ #:export (whispers-ssh-service-type
+ whispers-ssh-configuration
+ whispers-ssh-configuration?
+ ssh-user-group-keys-forwards
+ ssh-user-group-keys-forwards?
+ whispers-forwarding
+ whispers-forwarding?))
+
+(define-record-type* <whispers-ssh-configuration>
+ whispers-ssh-configuration make-whispers-ssh-configuration
+ whispers-ssh-configuration?
+ this-whispers-ssh-configuration
+ ;; A file-like object
+ (ssh-package whispers-ssh-configuration-ssh-package
+ (default openssh))
+ ;; A list of ssh-user-group-keys-forwards records
+ (users-groups-keys-forwards
+ whispers-ssh-configuration-users-groups-keys-forwards
+ (default '())))
+
+(define-record-type* <ssh-user-group-keys-forwards>
+ ssh-user-group-keys-forwards make-ssh-user-group-keys-forwards
+ ssh-user-group-keys-forwards?
+ this-ssh-agents-user-group-keys
+ ;; A whispers-user-group record
+ (user-and-group ssh-user-group-keys-forwards-user-and-group
+ (default (whispers-user-group)))
+ ;; A boolean value
+ (shell-tests? ssh-user-group-keys-forwards-shell-tests?
+ (default #f))
+ ;; A boolean value
+ (agent? ssh-user-group-keys-forwards-agent?
+ (default #t))
+ ;; A list of strings
+ (keys ssh-user-group-keys-forwards-keys
+ (default '()))
+ ;; A boolean value
+ (tunneler? ssh-user-group-keys-forwards-tunneler?
+ (default #f))
+ ;; A list of <whispers-forwarding> objects
+ (forwardings ssh-user-group-keys-forwards-forwardings
+ (default '())))
+
+(define-record-type* <whispers-forwarding>
+ whispers-forwarding make-whispers-forwarding
+ whispers-forwarding?
+ this-ssh-agents-user-group-keys
+ ;; A list of <ssh-forward-configuration> objects
+ (forwards whispers-forwarding-forwards
+ (default '()))
+ ;; A string.
+ (name-prefix whispers-forwarding-name-prefix
+ (default "ssh-forwards"))
+ ;; A boolean value.
+ (suffix-name? whispers-forwarding-suffix-name?
+ (default #t))
+ ;; A boolean value.
+ (use-agent? whispers-forwarding-use-agent?
+ (default #t))
+ ;; A boolean value.
+ (clear-password? whispers-forwarding-clear-password?
+ (default #f))
+ ;; A string.
+ (clear-password whispers-forwarding-clear-password
+ (default ""))
+ ;; A string.
+ (sshd-user whispers-forwarding-sshd-user
+ (default "root"))
+ ;; A string.
+ (sshd-host whispers-forwarding-sshd-host
+ (default "127.0.0.1"))
+ ;; An integer.
+ (sshd-port whispers-forwarding-sshd-port
+ (default 22))
+ ;; A string.
+ (strict-check whispers-forwarding-strict-check
+ (default "yes"))
+ ;; A list of strings.
+ (known-hosts-files whispers-forwarding-known-hosts-files
+ (default (list "~/.ssh/known_hosts"
+ "~/.ssh/known_hosts2")))
+ ;; An integer.
+ (server-alive-interval whispers-forwarding-server-alive-interval
+ (default 30))
+ ;; An integer.
+ (server-alive-count-max whispers-forwarding-server-alive-count-max
+ (default 6))
+ ;; A boolean value
+ (resurrect? whispers-forwarding-resurrect?
+ (default #t))
+ ;; A quoted cron time job specification
+ (resurrect-time-spec whispers-forwarding-resurrect-time-spec
+ (default ''(next-minute '(47))))
+ ;; A boolean value
+ (force-resurrect? whispers-forwarding-force-resurrect?
+ (default #t))
+ ;; A quoted cron time job specification
+ (force-resurrect-time-spec
+ whispers-forwarding-force-resurrect-time-spec
+ (default ''(next-hour '(3))))
+ ;; An integer
+ (timeout whispers-forwarding-timeout
+ (default 5))
+ ;; A boolean value.
+ (stealth? whispers-forwarding-stealth?
+ (default #t))
+ ;; A string.
+ (stealth-name-prefix whispers-forwarding-stealth-name-prefix
+ (default "ssh-forwards"))
+ ;; A boolean value.
+ (stealth-suffix-name? whispers-forwarding-stealth-suffix-name?
+ (default #t))
+ ;; A boolean value.
+ (stealth-use-agent? whispers-forwarding-stealth-use-agent?
+ (default #t))
+ ;; A boolean value.
+ (stealth-clear-password?
+ whispers-forwarding-stealth-clear-password?
+ (default #f))
+ ;; A string.
+ (stealth-clear-password
+ whispers-forwarding-stealth-clear-password
+ (default ""))
+ ;; A string.
+ (stealth-sshd-user whispers-forwarding-stealth-sshd-user
+ (default "root"))
+ ;; A string.
+ (stealth-sshd-host whispers-forwarding-stealth-sshd-host
+ (default "127.0.0.1"))
+ ;; An integer.
+ (stealth-sshd-port whispers-forwarding-stealth-sshd-port
+ (default 22))
+ ;; A string.
+ (stealth-strict-check whispers-forwarding-stealth-strict-check
+ (default "yes"))
+ ;; A list of strings.
+ (stealth-known-hosts-files
+ whispers-forwarding-stealth-known-hosts-files
+ (default (list "~/.ssh/known_hosts"
+ "~/.ssh/known_hosts2")))
+ ;; An integer.
+ (stealth-server-alive-interval
+ whispers-forwarding-stealth-server-alive-interval
+ (default 30))
+ ;; An integer.
+ (stealth-server-alive-count-max
+ whispers-forwarding-stealth-server-alive-count-max
+ (default 6))
+ ;; An integer.
+ (stealth-timeout whispers-forwarding-stealth-timeout
+ (default 5))
+ ;; An integer.
+ (stealth-proxy-port whispers-forwarding-stealth-proxy-port
+ (default 8585))
+ ;; A boolean value.
+ (%auto-start? whispers-forwarding-auto-start?
+ (default #t)))
+
+(define (log-folder-agent user)
+ "Return a string naming the path to the folder where the log file of
+the ssh agent daemon of the user named by the string USER is stored."
+ (string-append "/var/log/whispers/ssh/"
+ (user-container-name user)
+ "/ssh-agent"))
+
+(define (socket-folder-agent user)
+ "Return a string naming the path to the folder where the socket file
+of the ssh agent daemon of the user named by the string USER is located."
+ (string-append "/run/whispers/ssh/"
+ (user-container-name user)
+ "/ssh-agent/unix-sockets"))
+
+(define (log-folder-forwarding user conn)
+ "Return a string naming the path to the folder where the log file of
+the ssh tunneler of the user named by the string USER is stored."
+ (string-append "/var/log/whispers/ssh/"
+ (user-container-name user)
+ "/tunneler/"
+ conn))
+
+(define (base-folder-forwarding user conn)
+ "Return a string naming the path to the folder where the pid files
+of the ssh tunneler of the persistent ssh connection
+described by the string CONN of the user named by the string USER is
+located."
+ (string-append "/run/whispers/ssh/"
+ (user-container-name user)
+ "/tunneler/"
+ conn))
+
+(define (socket-folder-forwarding user conn)
+ "Return a string naming the path to the folder where the socket files
+of the ssh tunneler of the persistent ssh connection
+described by the string CONN of the user named by the string USER is
+located."
+ (string-append "/run/whispers/ssh/"
+ (user-container-name user)
+ "/tunneler/"
+ conn
+ "/unix-sockets"))
+
+(define (agent ssh-package user keys)
+ "Returns an ssh agent guix service for an ssh agent daemon from the
+package SSH-PACKAGE owned by the user named by the string USER and with
+the private key files named in the list of string KEYS auto-loaded at
+startup."
+ (service
+ ssh-agent-service-type
+ (ssh-agent-configuration (ssh-package ssh-package)
+ (log-folder (log-folder-agent user))
+ (socket-folder (socket-folder-agent user))
+ (auto-added-keys keys))))
+
+(define (forwarding->conn-strings forwarding)
+ "Returns a list of strings used to hopefully uniquely identify the
+ persistent ssh connections to remote handles of remote hosts,
+configured from the fields of FORWARDING, a record of the
+<whispers-forwarding> type. The strings are used as sub-folders names
+for files relevant to the extended shepherd services. The list contains
+two strings if the forwarding is extended with stealth switched on, and
+one string otherwise."
+ (let ((sshd-user (whispers-forwarding-sshd-user forwarding))
+ (host (whispers-forwarding-sshd-host forwarding))
+ (port (whispers-forwarding-sshd-port forwarding))
+ (stealth? (whispers-forwarding-stealth? forwarding))
+ (stealth-sshd-user (whispers-forwarding-stealth-sshd-user
+ forwarding))
+ (stealth-host (whispers-forwarding-stealth-sshd-host forwarding))
+ (stealth-port (whispers-forwarding-stealth-sshd-port forwarding)))
+ (append (list (string-append "ssh-connection_"
+ sshd-user
+ "@"
+ host
+ ":"
+ (number->string port)
+ (if stealth?
+ (string-append "_proxy_"
+ stealth-sshd-user
+ "@"
+ stealth-host
+ ":"
+ (number->string
+ stealth-port))
+ "")))
+ (if stealth?
+ (list (string-append "ssh-connection_"
+ stealth-sshd-user
+ "@"
+ stealth-host
+ ":"
+ (number->string stealth-port)))
+ (list)))))
+
+(define (tunneler ssh-package
+ user
+ forwarding)
+ "Returns a ssh tunneler Guix service using the
+package SSH-PACKAGE, owned by the user named by the string USER,
+defined by FORWARDING, a record of the <whispers-forwarding> type."
+ (let* ((forwards (whispers-forwarding-forwards forwarding))
+ (lieutenant-path (string-append "/ssh/"
+ (user-container-name user)
+ "/tunneler"))
+ (nprefix (whispers-forwarding-name-prefix forwarding))
+ (suffix? (whispers-forwarding-suffix-name? forwarding))
+ (agent? (whispers-forwarding-use-agent? forwarding))
+ (agent-socket (string-append (socket-folder-agent user)
+ "/ssh-agent.sock"))
+ (clear? (whispers-forwarding-clear-password? forwarding))
+ (clear (whispers-forwarding-clear-password forwarding))
+ (sshd-user (whispers-forwarding-sshd-user forwarding))
+ (host (whispers-forwarding-sshd-host forwarding))
+ (port (whispers-forwarding-sshd-port forwarding))
+ (strict (whispers-forwarding-strict-check forwarding))
+ (kh-files (whispers-forwarding-known-hosts-files forwarding))
+ (sa-count-max (whispers-forwarding-server-alive-count-max
+ forwarding))
+ (sa-int (whispers-forwarding-server-alive-interval forwarding))
+ (resurrect? (whispers-forwarding-resurrect? forwarding))
+ (resurrect-time (whispers-forwarding-resurrect-time-spec
+ forwarding))
+ (force-resurrect? (whispers-forwarding-force-resurrect? forwarding))
+ (force-resurrect-time (whispers-forwarding-force-resurrect-time-spec
+ forwarding))
+ (timeout (whispers-forwarding-timeout forwarding))
+ (stealth? (whispers-forwarding-stealth? forwarding))
+ (stealth-prefix (whispers-forwarding-stealth-name-prefix
+ forwarding))
+ (stealth-suffix? (whispers-forwarding-stealth-suffix-name?
+ forwarding))
+ (stealth-agent? (whispers-forwarding-stealth-use-agent? forwarding))
+ (stealth-clear? (whispers-forwarding-stealth-clear-password?
+ forwarding))
+ (stealth-clear (whispers-forwarding-stealth-clear-password
+ forwarding))
+ (stealth-sshd-user (whispers-forwarding-stealth-sshd-user
+ forwarding))
+ (stealth-host (whispers-forwarding-stealth-sshd-host forwarding))
+ (stealth-port (whispers-forwarding-stealth-sshd-port forwarding))
+ (stealth-timeout (whispers-forwarding-stealth-timeout forwarding))
+ (stealth-proxy-port (whispers-forwarding-stealth-proxy-port
+ forwarding))
+ (stealth-strict (whispers-forwarding-stealth-strict-check
+ forwarding))
+ (stealth-kh-files (whispers-forwarding-stealth-known-hosts-files
+ forwarding))
+ (stealth-sa-count-max
+ (whispers-forwarding-stealth-server-alive-count-max
+ forwarding))
+ (stealth-sa-int (whispers-forwarding-stealth-server-alive-interval
+ forwarding))
+ (auto? (whispers-forwarding-auto-start? forwarding))
+ (conn (forwarding->conn-strings forwarding)))
+ (service
+ persistent-ssh-service-type
+ (ssh-connection-configuration
+ (ssh-package ssh-package)
+ (lieutenant? #t)
+ (lieutenant-path lieutenant-path)
+ (name-prefix nprefix)
+ (suffix-name? suffix?)
+ (agent? agent?)
+ (agent-socket agent-socket)
+ (clear-password? clear?)
+ (sshd-user-password clear)
+ (require-networking? #f)
+ (pid-folder-override? #t)
+ (pid-folder-override (base-folder-forwarding user (car conn)))
+ (dedicated-log-file? #t)
+ (log-folder-override? #t)
+ (log-folder-override (log-folder-forwarding user (car conn)))
+ (sshd-user sshd-user)
+ (forwards forwards)
+ (sshd-host host)
+ (sshd-port port)
+ (strict-check strict)
+ (known-hosts-files kh-files)
+ (server-alive-interval sa-int)
+ (server-alive-count-max sa-count-max)
+ (%cron-resurrect? resurrect?)
+ (resurrect-time-spec resurrect-time)
+ (%cron-force-resurrect? force-resurrect?)
+ (force-resurrect-time-spec force-resurrect-time)
+ (timeout-override? #t)
+ (timeout-override timeout)
+ (socks-proxy-config
+ (socks-proxy-configuration
+ (use-proxy? stealth?)
+ (dynamic-forward
+ (if stealth?
+ (ssh-connection-configuration
+ (ssh-package ssh-package)
+ (lieutenant? #t)
+ (lieutenant-path lieutenant-path)
+ (name-prefix stealth-prefix)
+ (suffix-name? stealth-suffix?)
+ (agent? stealth-agent?)
+ (agent-socket agent-socket)
+ (clear-password? stealth-clear?)
+ (sshd-user-password stealth-clear)
+ (require-networking? #f)
+ (pid-folder-override? #t)
+ (pid-folder-override (base-folder-forwarding user (cadr conn)))
+ (dedicated-log-file? #t)
+ (log-folder-override? #t)
+ (log-folder-override (log-folder-forwarding user (cadr conn)))
+ (sshd-user stealth-sshd-user)
+ (forwards
+ (list (dynamic-forward-configuration
+ (entry-port stealth-proxy-port))))
+ (sshd-host stealth-host)
+ (sshd-port stealth-port)
+ (strict-check stealth-strict)
+ (known-hosts-files stealth-kh-files)
+ (server-alive-interval stealth-sa-int)
+ (server-alive-count-max stealth-sa-count-max)
+ (timeout-override? #t)
+ (timeout-override stealth-timeout)
+ (%auto-start? auto?))
+ #f))))
+ (%auto-start? auto?)))))
+
+(define (extra-actions-forwardings user group conn-list)
+ "Return a list of <shepherd-action> records for the creation and
+destruction of the folders and temporary file systems necessary for the
+operation of the ssh tunneler connections owned by the user named by the
+string USER to the remote defined by the list of strings
+CONN-LIST. Group ownership of the folders and tmpfs goes to the group
+named by the string GROUP."
+ (list (shepherd-action
+ (name 'pre-start)
+ (documentation "Create the directories and tmpfs mounts
+used by a tunneler connection.")
+ (procedure
+ #~(lambda (running)
+ `#$(map (lambda (conn)
+ (list #~,(action 'tunneler
+ 'make-directory
+ #$(log-folder-forwarding user
+ conn)
+ #$user
+ #$group
+ #$(number->string #o755
+ 8))
+ ;; The let form is insuring that the
+ ;; parent folder is created before its
+ ;; sub-folder. Good idea, what could
+ ;; possibly go wrong with this
+ ;; clusterfuck?
+ #~,(let ((dummy
+ (action 'tunneler
+ 'make-tmpfs
+ #$(base-folder-forwarding
+ user
+ conn)
+ #$user
+ #$group
+ #$(number->string #o755
+ 8))))
+ (action 'tunneler
+ 'make-tmpfs
+ #$(socket-folder-forwarding
+ user
+ conn)
+ #$user
+ #$group
+ #$(number->string #o700
+ 8)))))
+ conn-list))))
+ (shepherd-action
+ (name 'post-stop)
+ (documentation "Unmount the tmpfs mounts used by a tunneler
+ connection.")
+ (procedure
+ #~(lambda (running)
+ `#$(map (lambda (conn)
+ ;; The let form is insuring that the parent
+ ;; folder is deleted after its
+ ;; sub-folder. Ditto.
+ (list #~,(let ((dummy
+ (action 'tunneler
+ 'clear-tmpfs
+ #$(socket-folder-forwarding
+ user
+ conn))))
+ (action 'tunneler
+ 'clear-tmpfs
+ #$(base-folder-forwarding
+ user
+ conn)))))
+ conn-list))))))
+
+(define (tunnelers ssh-package user group forwardings)
+ (service
+ whispers-service-type
+ (whispers-configuration (name 'tunneler)
+ (lieutenants (map (lambda (forwarding)
+ (tunneler ssh-package
+ user
+ forwarding))
+ forwardings))
+ (user user)
+ (group group)
+ (pre-start-action? #t)
+ (post-stop-action? #t)
+ (extra-actions
+ (extra-actions-forwardings
+ user
+ group
+ (apply append
+ (map forwarding->conn-strings
+ forwardings)))))))
+
+(define (extra-actions-user user group)
+ "Return a list of <shepherd-action> records for the creation and
+destruction of the folders and temporary file systems necessary for the
+operation of the ssh agent daemon of the user named by the string
+USER. Group ownership of the folders and tmpfs goes to the group named
+by the string GROUP."
+ (let* ((user-str (user-container-name user))
+ (user-sym (string->symbol user-str)))
+ (list (shepherd-action
+ (name 'pre-start)
+ (documentation "Create the directories and tmpfs mounts
+used by the ssh-agent.")
+ (procedure
+ #~(lambda (running)
+ (action '#$user-sym
+ 'make-directory
+ #$(log-folder-agent user-str)
+ #$user
+ #$group
+ #$(number->string #o755 8))
+ (action '#$user-sym
+ 'make-tmpfs
+ (string-append "/run/whispers/"
+ "ssh/"
+ #$user-str
+ "/ssh-agent/")
+ #$user
+ #$group
+ #$(number->string #o755 8))
+ (action '#$user-sym
+ 'make-tmpfs
+ #$(socket-folder-agent user)
+ #$user
+ #$group
+ #$(number->string #o700 8)))))
+ (shepherd-action
+ (name 'post-stop)
+ (documentation "Unmount the tmpfs mounts used by the ssh-agent.")
+ (procedure
+ #~(lambda (running)
+ (action '#$user-sym
+ 'clear-tmpfs
+ #$(socket-folder-agent user))
+ (action '#$user-sym
+ 'clear-tmpfs
+ (string-append "/run/whispers/"
+ "ssh/"
+ #$user-str
+ "/ssh-agent"))))))))
+
+(define (user-lieutenant agent?
+ tunneler?
+ user
+ group
+ keys
+ forwardings
+ ssh-package)
+ "Returns a whispers sub-tree for a single user's section of a whispers
+ssh sub-tree, owned by the user named by the string USER and the group
+named by the string GROUP, at the tips of which a ssh agent service
+rendering availbale the private keys defined by the list of strings KEYS
+is daemonized when AGENT? evaluates to a true value, and/or ssh forwards
+as defined by the <whispers-forwarding> type record FORWARDINGS are
+daemonized when TUNNELER? evaluates to a true value. Those services are
+provided by the programs of the package SSH-PACKAGE."
+ (service whispers-service-type
+ (whispers-configuration
+ (name (string->symbol (user-container-name user)))
+ (lieutenants (append (if agent?
+ (list (agent ssh-package
+ user
+ keys))
+ (list))
+ (if tunneler?
+ (list (tunnelers ssh-package
+ user
+ group
+ forwardings))
+ (list))))
+ (user user)
+ (group group)
+ (pre-start-action? #t)
+ (post-stop-action? #t)
+ (extra-actions (extra-actions-user user
+ group)))))
+
+(define (whispers-ssh-tree config)
+ "Returns a whispers service tree for a whispers ssh sub-tree,
+configurable by CONFIG, a record of the <whispers-ssh-configuration>
+type."
+ (let* ((ssh-package (whispers-ssh-configuration-ssh-package config))
+ (ugks (whispers-ssh-configuration-users-groups-keys-forwards
+ config))
+ (user-group ssh-user-group-keys-forwards-user-and-group)
+ (user (lambda (ugk)
+ (whispers-user-group-user (user-group ugk))))
+ (group (lambda (ugk)
+ (whispers-user-group-group (user-group ugk))))
+ (ag? (lambda (ugk)
+ (ssh-user-group-keys-forwards-agent? ugk)))
+ (keys (lambda (ugk)
+ (ssh-user-group-keys-forwards-keys ugk)))
+ (tun? (lambda (ugk)
+ (ssh-user-group-keys-forwards-tunneler? ugk)))
+ (fwds (lambda (ugk)
+ (ssh-user-group-keys-forwards-forwardings ugk))))
+ (list (service whispers-service-type
+ (whispers-configuration
+ (name 'ssh)
+ (lieutenants (map (lambda (ugk)
+ (user-lieutenant (ag? ugk)
+ (tun? ugk)
+ (user ugk)
+ (group ugk)
+ (keys ugk)
+ (fwds ugk)
+ ssh-package))
+ ugks)))))))
+
+(define whispers-ssh-service-type
+ (service-type
+ (name '(whispers-ssh))
+ (description "Daemonized per-user ssh agents and ssh forwards")
+ (extensions (list (service-extension whispers-service-type
+ whispers-ssh-tree)))
+ (default-value (whispers-ssh-configuration))))
diff --git a/whispers/services/whispers/vpn.scm b/whispers/services/whispers/vpn.scm
new file mode 100644
index 0000000..55847ee
--- /dev/null
+++ b/whispers/services/whispers/vpn.scm
@@ -0,0 +1,3424 @@
+;;; Whispers --- Stealth VPN and ssh tunneler
+;;; Copyright © 2023 Runciter <runciter@whispers-vpn.org>
+;;;
+;;; This file is part of Whispers.
+;;;
+;;; Whispers 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.
+;;;
+;;; Whispers 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 Whispers. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (whispers services whispers vpn)
+ #:use-module (guix gexp)
+ #:use-module (guix records)
+ #:use-module (gnu system shadow)
+ #:use-module (gnu services)
+ #:use-module (gnu services shepherd)
+ #:use-module (whispers services whispers)
+ #:use-module (whispers services ssh-tunneler)
+ #:use-module (gnu packages base)
+ #:use-module (gnu packages guile)
+ #:use-module (gnu packages ssh)
+ #:use-module (gnu packages linux)
+ #:use-module (gnu packages networking)
+ #:export (whispers-vpn-service-type
+ whispers-vpn-configuration
+ whispers-vpn-configuration?))
+
+(define-record-type* <whispers-vpn-configuration>
+ whispers-vpn-configuration make-whispers-vpn-configuration
+ whispers-vpn-configuration?
+ this-whispers-vpn-configuration
+ ;; A file-like object.
+ (ssh-package whispers-vpn-configuration-ssh-package
+ (default openssh))
+ ;; A file-like-object.
+ (procps-package whispers-vpn-configuration-procps-package
+ (default procps))
+ ;; A file-like-object.
+ (iproute-package whispers-vpn-configuration-iproute-package
+ (default iproute))
+ ;; A file-like-object.
+ (iptables-package whispers-vpn-configuration-iptables-package
+ (default iptables))
+ ;; A file-like-object.
+ (sed-package whispers-vpn-configuration-sed-package
+ (default sed))
+ ;; A network-constants record.
+ (constants whispers-vpn-configuration-constants
+ (default (network-constants)))
+ ;; A boolean value.
+ (masquerade? whispers-vpn-configuration-masquerade?
+ (default #t))
+ ;; A boolean value.
+ (ipv4-ip-forward? whispers-vpn-configuration-ipv4-ip-forward?
+ (default #t))
+ ;; A boolean value.
+ (client? whispers-vpn-configuration-client?
+ (default #f))
+ ;; A boolean value.
+ (manual-physical-if? whispers-vpn-configuration-manual-physical-if?
+ (default #f))
+ ;; A string.
+ (physical-if-override whispers-vpn-configuration-physical-if-override
+ (default "eth0"))
+ ;; A boolean value.
+ (manual-phy-gateway? whispers-vpn-configuration-manual-phy-gateway?
+ (default #f))
+ ;; A string.
+ (phy-gateway-override whispers-vpn-configuration-phy-gateway-override
+ (default "192.168.1.1"))
+ ;; An integer
+ (client-tun-device whispers-vpn-configuration-client-tun-device
+ (default 0))
+ ;; A string.
+ (server-sshd-host whispers-vpn-configuration-server-sshd-host
+ (default "127.0.0.1"))
+ ;; An integer.
+ (server-sshd-port whispers-vpn-configuration-server-sshd-port
+ (default 22))
+ ;; A string.
+ (proxy-sshd-user whispers-vpn-configuration-proxy-sshd-user
+ (default "root"))
+ ;; A string.
+ (proxy-sshd-host whispers-vpn-configuration-proxy-sshd-host
+ (default "127.0.0.1"))
+ ;; An integer.
+ (proxy-sshd-port whispers-vpn-configuration-proxy-sshd-port
+ (default 22))
+ ;; An integer.
+ (client-sshd-port whispers-vpn-configuration-client-sshd-port
+ (default 22))
+ ;; A boolean value.
+ (stealth? whispers-vpn-configuration-stealth?
+ (default #f))
+ ;; An integer.
+ (stealth-base-port whispers-vpn-configuration-stealth-base-port
+ (default 31273))
+ ;; A boolean value.
+ (stealth-clear-password?
+ whispers-vpn-configuration-stealth-clear-password?
+ (default #f))
+ ;; A string.
+ (stealth-user-password whispers-vpn-configuration-stealth-user-password
+ (default "none"))
+ ;; An integer.
+ (forward-port whispers-vpn-configuration-forward-port
+ (default 36492))
+ ;; An integer.
+ ;; If there's a NIC, sshd-port can't be used, need an overridable default.
+ (forward-exit-port whispers-vpn-configuration-forward-exit-port
+ (default
+ (whispers-vpn-configuration-server-sshd-port
+ this-whispers-vpn-configuration))
+ (thunked))
+ ;; A boolean value.
+ (vpn-server-clear-password?
+ whispers-vpn-configuration-vpn-server-clear-password?
+ (default #f))
+ ;; A string.
+ (vpn-server-user-password
+ whispers-vpn-configuration-vpn-server-user-password
+ (default "none"))
+ ;; A quoted cron job time specification.
+ (forward-resurrect-time-spec
+ whispers-vpn-configuration-forward-resurrect-time-spec
+ (default ''(next-minute '(34))))
+ ;; A boolean value.
+ (client-whispers-user-clear-password?
+ whispers-vpn-configuration-client-whispers-user-clear-password?
+ (default #f))
+ ;; A string.
+ (client-whispers-password
+ whispers-vpn-configuration-client-whispers-password
+ (default "none"))
+ ;; A boolean value.
+ (%auto-register? whispers-vpn-configuration-auto-register?
+ (default #f))
+ ;; A boolean value.
+ (%auto-connect? whispers-vpn-configuration-auto-connect?
+ (default #f)))
+
+(define-record-type* <network-constants>
+ network-constants make-network-constants
+ network-constants?
+ this-network-constants
+ ;; A string.
+ (ip-prefix network-constants-ip-prefix
+ (default "10.0.0"))
+ ;; An integer.
+ (lowest-ip network-constants-lowest-ip
+ (default 10))
+ ;; An integer.
+ (lowest-tun-number network-constants-lowest-tun-number
+ (default
+ (quotient
+ (network-constants-lowest-ip
+ this-network-constants)
+ 2))
+ (thunked))
+ ;; An integer.
+ (base-port-reverse network-constants-base-port-reverse
+ (default 37215))
+ ;; An integer.
+ (handshake-port network-constants-handshake-port
+ (default 38573)))
+
+(define (stealth-record config stealth-port)
+ (let* ((ssh-package (whispers-vpn-configuration-ssh-package config))
+ (sshd-user (whispers-vpn-configuration-proxy-sshd-user config))
+ (sshd-host (whispers-vpn-configuration-proxy-sshd-host config))
+ (sshd-port (whispers-vpn-configuration-proxy-sshd-port config))
+ (forward-port (whispers-vpn-configuration-forward-port config))
+ (clear-password?
+ (whispers-vpn-configuration-stealth-clear-password? config))
+ (user-password
+ (whispers-vpn-configuration-stealth-user-password config))
+ (pid-folder "/run/whispers/vpn/ssh-tunneler")
+ (log-folder "/var/log/whispers/vpn/ssh-tunneler")
+ (auto-register? (whispers-vpn-configuration-auto-register? config)))
+ (ssh-connection-configuration (ssh-package ssh-package)
+ (sshd-user sshd-user)
+ (sshd-host sshd-host)
+ (known-hosts-files '("/dev/null"))
+ (strict-check "no")
+ (require-networking? #f)
+ (sshd-port sshd-port)
+ (forwards
+ (list (dynamic-forward-configuration
+ (entry-port stealth-port))))
+ (clear-password? clear-password?)
+ (sshd-user-password user-password)
+ (pid-folder-override? #t)
+ (pid-folder-override pid-folder)
+ (dedicated-log-file? #t)
+ (log-rotate? #t)
+ (log-folder-override? #t)
+ (log-folder-override log-folder)
+ ;; FIXME: auto registration not working in
+ ;; the demo script.
+ (%auto-start? auto-register?))))
+
+(define (forward-configuration config)
+ (let* ((ssh-package (whispers-vpn-configuration-ssh-package config))
+ (stealth? (whispers-vpn-configuration-stealth? config))
+ (socks-port (whispers-vpn-configuration-stealth-base-port config))
+ (stealth-config (stealth-record config socks-port))
+ (sshd-user "whispers")
+ (sshd-host (whispers-vpn-configuration-server-sshd-host config))
+ (sshd-port (whispers-vpn-configuration-server-sshd-port config))
+ (forward-port (whispers-vpn-configuration-forward-port config))
+ (exit-port (whispers-vpn-configuration-forward-exit-port config))
+ (clear-password?
+ (whispers-vpn-configuration-vpn-server-clear-password? config))
+ (user-password
+ (whispers-vpn-configuration-vpn-server-user-password config))
+ (pid-folder "/run/whispers/vpn/ssh-tunneler")
+ (log-folder "/var/log/whispers/vpn/ssh-tunneler")
+ (auto-register? (whispers-vpn-configuration-auto-register? config)))
+ (ssh-connection-configuration (ssh-package ssh-package)
+ (require-networking? #f)
+ (socks-proxy-config
+ (socks-proxy-configuration
+ (use-proxy? stealth?)
+ (dynamic-forward (if stealth?
+ stealth-config
+ #f))))
+ (sshd-user sshd-user)
+ (sshd-host sshd-host)
+ (sshd-port sshd-port)
+ (known-hosts-files '("/dev/null"))
+ (strict-check "no")
+ (forwards
+ (list (port-forward-configuration
+ (forward-type 'port)
+ (entry-port forward-port)
+ (exit-port exit-port))))
+ (clear-password? clear-password?)
+ (sshd-user-password user-password)
+ (pid-folder-override? #t)
+ (pid-folder-override pid-folder)
+ (dedicated-log-file? #t)
+ (log-rotate? #t)
+ (log-folder-override? log-folder)
+ (log-folder-override log-folder)
+ (%auto-start? auto-register?))))
+
+(define (handshake-forward-configuration config)
+ (let* ((ssh-package (whispers-vpn-configuration-ssh-package config))
+ (stealth? (whispers-vpn-configuration-stealth? config))
+ (base-port (whispers-vpn-configuration-stealth-base-port config))
+ (stealth-config (stealth-record config
+ (+ base-port
+ 1)))
+ (sshd-user "whispers")
+ (sshd-host (whispers-vpn-configuration-server-sshd-host config))
+ (sshd-port (whispers-vpn-configuration-server-sshd-port config))
+ (constants (whispers-vpn-configuration-constants config))
+ (handshake-port (network-constants-handshake-port constants))
+ (exit-port (whispers-vpn-configuration-client-sshd-port config))
+ (clear-password?
+ (whispers-vpn-configuration-vpn-server-clear-password? config))
+ (user-password
+ (whispers-vpn-configuration-vpn-server-user-password config))
+ (herd-path "/run/current-system/profile/bin/herd")
+ (handshake (string-append herd-path
+ " "
+ "lieutenant-action"
+ " "
+ "whispers"
+ " "
+ "lieutenant-action"
+ " "
+ "vpn"
+ " "
+ "complete-handshake"
+ " "
+ "network-rw"))
+ (pid-folder "/run/whispers/vpn/ssh-tunneler")
+ (log-folder "/var/log/whispers/vpn/ssh-tunneler"))
+ (ssh-connection-configuration (ssh-package ssh-package)
+ (require-networking? #f)
+ (socks-proxy-config
+ (socks-proxy-configuration
+ (use-proxy? stealth?)
+ (dynamic-forward (if stealth?
+ stealth-config
+ #f))))
+ (sshd-user sshd-user)
+ (sshd-host sshd-host)
+ (sshd-port sshd-port)
+ (known-hosts-files '("/dev/null"))
+ (strict-check "no")
+ (forwards
+ (list (reverse-port-forward-configuration
+ (forward-type 'reverse-port)
+ (entry-port handshake-port)
+ (exit-port exit-port))))
+ (clear-password? clear-password?)
+ (sshd-user-password user-password)
+ (extra-local-commands `(,handshake))
+ (pid-folder-override? #t)
+ (pid-folder-override pid-folder)
+ (dedicated-log-file? #t)
+ (log-rotate? #t)
+ (log-folder-override? #t)
+ (log-folder-override log-folder)
+ (%auto-start? #f))))
+
+(define (reverse-stealth-conf config)
+ (let ((socks-port (whispers-vpn-configuration-stealth-base-port
+ config)))
+ (stealth-record config
+ (+ socks-port
+ 2))))
+
+(define (reverse-forward-configurations config)
+ (let* ((ssh-package (whispers-vpn-configuration-ssh-package config))
+ (stealth? (whispers-vpn-configuration-stealth? config))
+ (sshd-user "whispers")
+ (sshd-host (whispers-vpn-configuration-server-sshd-host config))
+ (sshd-port (whispers-vpn-configuration-server-sshd-port config))
+ (exit-port (whispers-vpn-configuration-client-sshd-port config))
+ (clear-password?
+ (whispers-vpn-configuration-vpn-server-clear-password? config))
+ (user-password
+ (whispers-vpn-configuration-vpn-server-user-password config))
+ (empty-net (empty-network (whispers-vpn-configuration-constants
+ config)))
+ (pid-folder "/run/whispers/vpn/ssh-tunneler")
+ (log-folder "/var/log/whispers/vpn/ssh-tunneler")
+ (herd-path "/run/current-system/profile/bin/herd")
+ (tunnel (string-append herd-path
+ " "
+ "lieutenant-action"
+ " "
+ "whispers"
+ " "
+ "lieutenant-action"
+ " "
+ "vpn"
+ " "
+ "tun-start-dev"
+ " "
+ "connecting"))
+ (net-constants (whispers-vpn-configuration-constants config))
+ (empty-net (empty-network net-constants)))
+ (map (lambda (empty-voucher)
+ (let* ((entr ((lambda (lst)
+ (if (null? lst)
+ #f
+ (cadr (car lst)))) (filter (lambda (entry)
+ (equal?
+ (car entry)
+ 'reverse-port))
+ empty-voucher)))
+ (dyn (if stealth?
+ (reverse-stealth-conf config)
+ #f))
+ (forw (list (reverse-port-forward-configuration
+ (forward-type 'reverse-port)
+ (entry-port entr)
+ (exit-port exit-port)))))
+ (ssh-connection-configuration (ssh-package ssh-package)
+ (require-networking? #f)
+ (socks-proxy-config
+ (socks-proxy-configuration
+ (use-proxy? stealth?)
+ (dynamic-forward dyn)))
+ (sshd-user sshd-user)
+ (sshd-host sshd-host)
+ (sshd-port sshd-port)
+ (known-hosts-files '("/dev/null"))
+ (strict-check "no")
+ (forwards forw)
+ (clear-password? clear-password?)
+ (sshd-user-password user-password)
+ (extra-local-commands `(,tunnel))
+ (pid-folder-override? #t)
+ (pid-folder-override pid-folder)
+ (dedicated-log-file? #t)
+ (log-rotate? #t)
+ (log-folder-override? #t)
+ (log-folder-override log-folder)
+ (%auto-start? #f))))
+ empty-net)))
+
+(define (tun-stealth-conf config)
+ (let ((socks-port (whispers-vpn-configuration-stealth-base-port
+ config)))
+ (stealth-record config
+ (+ socks-port
+ 3))))
+
+(define (tun-device-forward-configurations config)
+ (let* ((ssh-package (whispers-vpn-configuration-ssh-package config))
+ (stealth? (whispers-vpn-configuration-stealth? config))
+ (socks-port (whispers-vpn-configuration-stealth-base-port config))
+ (sshd-user "whispers")
+ (sshd-host (whispers-vpn-configuration-server-sshd-host config))
+ (sshd-port (whispers-vpn-configuration-server-sshd-port config))
+ (exit-port (whispers-vpn-configuration-client-sshd-port config))
+ (clear-password?
+ (whispers-vpn-configuration-vpn-server-clear-password? config))
+ (user-password
+ (whispers-vpn-configuration-vpn-server-user-password config))
+ (pid-folder "/run/whispers/vpn/ssh-tunneler")
+ (log-folder "/var/log/whispers/vpn/ssh-tunneler")
+ (herd-path "/run/current-system/profile/bin/herd")
+ (tun-int (whispers-vpn-configuration-client-tun-device config))
+ (tun-str (number->string tun-int))
+ (complete-connect (string-append herd-path
+ " "
+ "lieutenant-action"
+ " "
+ "whispers"
+ " "
+ "lieutenant-action"
+ " "
+ "vpn"
+ " "
+ "set-connected-knock"
+ " "
+ "network-rw"
+ " "
+ "&&"
+ " "
+ herd-path
+ " "
+ "lieutenant-action"
+ " "
+ "whispers"
+ " "
+ "start-tun"
+ tun-str
+ " "
+ "vpn"))
+ (net-constants (whispers-vpn-configuration-constants config))
+ (empty-net (empty-network net-constants)))
+ (map (lambda (empty-voucher)
+ (let* ((entr ((lambda (lst)
+ (if (null? lst)
+ #f
+ (cadr (car lst)))) (filter
+ (lambda (entry)
+ (equal?
+ (car entry)
+ 'tun-device-number))
+ empty-voucher)))
+ (dyn (if stealth?
+ (tun-stealth-conf config)
+ #f))
+ (forw (list (tunnel-forward-configuration
+ (entry-type 'preset)
+ (exit-type 'preset)
+ (entry-tun tun-int)
+ (exit-tun entr)))))
+ (ssh-connection-configuration (ssh-package ssh-package)
+ (require-networking? #f)
+ (socks-proxy-config
+ (socks-proxy-configuration
+ (use-proxy? stealth?)
+ (dynamic-forward dyn)))
+ (sshd-user sshd-user)
+ (sshd-host sshd-host)
+ (sshd-port sshd-port)
+ (known-hosts-files '("/dev/null"))
+ (strict-check "no")
+ (forwards forw)
+ (clear-password? clear-password?)
+ (sshd-user-password user-password)
+ (extra-local-commands
+ `(,complete-connect))
+ (pid-folder-override? #t)
+ (pid-folder-override pid-folder)
+ (dedicated-log-file? #t)
+ (log-rotate? #t)
+ (log-folder-override? #t)
+ (log-folder-override log-folder)
+ (%auto-start? #f))))
+ empty-net)))
+
+(define (int-range start end)
+ (if (< end start)
+ '()
+ (cons start (int-range (+ start 1) end))))
+
+(define (empty-network constants)
+ "Return the network state of an empty network configurabale by
+CONSTANTS, a record of tne <network-constants> type."
+ (let ((ip-concat
+ (lambda (ip-prefix last-byte)
+ (string-append ip-prefix
+ "."
+ (number->string last-byte)))))
+ (map (lambda (voucher-index)
+ (let ((ip-prefix (network-constants-ip-prefix constants))
+ (lowest-ip (network-constants-lowest-ip constants))
+ (lowest-tun-number (network-constants-lowest-tun-number
+ constants))
+ (lowest-port-number (network-constants-base-port-reverse
+ constants)))
+ `((voucher-number ,voucher-index)
+ (client-hostname #f)
+ (tun-device-number ,(+ lowest-tun-number voucher-index))
+ (reverse-port ,(+ lowest-port-number voucher-index))
+ (server-ip ,(ip-concat ip-prefix (+ lowest-ip
+ (* voucher-index 2))))
+ (client-ip ,(ip-concat ip-prefix (+ lowest-ip
+ (* voucher-index 2)
+ 1)))
+ (tun-request? #f)
+ (connected? #f))))
+ (int-range 0
+ (- 127
+ (quotient (network-constants-lowest-ip constants)
+ 2))))))
+
+(define (tun-dev-str tun-int)
+ "Returns the string naming a TUN device whose number is the integer
+TUN-INT."
+ (string-append "tun"
+ (number->string tun-int)))
+
+(define (tun-dev-sym tun-int)
+ "Returns a symbol cast from the string naming a TUN device whose
+number is the integer TUN-INT."
+ (string->symbol (tun-dev-str tun-int)))
+
+(define (ipv4-forward-actions config)
+ "Returns a list of <shepherd-action> records for the 'ipv4-ip-forward
+lieutenant of the 'tcp-ip service, used by the VPN server to turn IPv4
+forwarding on and off on demand as appropriate, configurable by CONFIG,
+a record of the <whispers-vpn-configuration> type."
+ (let* ((procps-pk (whispers-vpn-configuration-procps-package config))
+ (sysctl-exec (file-append procps-pk
+ "/sbin/sysctl")))
+ (list (shepherd-action
+ (name 'pre-start)
+ (documentation "Turn on IPv4 forwarding for this server.")
+ (procedure
+ #~(lambda (running)
+ (perform-service-action (lookup-service 'ipv4-ip-forward)
+ 'ipv4-ip-forward-on))))
+ (shepherd-action
+ (name 'post-stop)
+ (documentation "Turn off IPv4 forwarding for this server.")
+ (procedure
+ #~(lambda (running)
+ (perform-service-action (lookup-service 'ipv4-ip-forward)
+ 'ipv4-ip-forward-off))))
+ (shepherd-action
+ (name 'ipv4-ip-forward-on)
+ (documentation "Turn on IPv4 forwarding in the kernel
+run-time parameters.")
+ (procedure
+ #~(lambda (running)
+ (fork+exec-command (list #$sysctl-exec
+ "-w"
+ "net.ipv4.ip_forward=1")))))
+ (shepherd-action
+ (name 'ipv4-ip-forward-off)
+ (documentation "Turn off IPv4 forwarding in the kernel
+run-time parameters.")
+ (procedure
+ #~(lambda (running)
+ (fork+exec-command (list #$sysctl-exec
+ "-w"
+ "net.ipv4.ip_forward=0"))))))))
+
+(define (masquerade-actions config)
+ "Returns a list of <shepherd-action> records for the 'masquerade
+lieutenant of the 'tcp-ip service, used by the VPN servier to turn NAT
+masquerading on and off on demand as appropriate, configurable by
+CONFIG, a record of the <whispers-vpn-configuration> type."
+ (let* ((iptb-pk (whispers-vpn-configuration-iptables-package config))
+ (iptables-exec (file-append iptb-pk
+ "/sbin/iptables"))
+ (ip-package (whispers-vpn-configuration-iproute-package config))
+ (ip-exec (file-append ip-package
+ "/sbin/ip"))
+ (sed-package (whispers-vpn-configuration-sed-package
+ config))
+ (sed-exec (file-append sed-package
+ "/bin/sed"))
+ (herd-path "/run/current-system/profile/bin/herd")
+ (socket-path "/run/whispers/vpn/unix-sockets/vpn.sock"))
+ (list (shepherd-action
+ (name 'pre-start)
+ (documentation "Turn on NAT masquerading for this server.")
+ (procedure
+ #~(lambda (running)
+ (perform-service-action (lookup-service 'masquerade)
+ 'masquerade-on))))
+ (shepherd-action
+ (name 'post-stop)
+ (documentation "Turn off NAT masquerading for this server.")
+ (procedure
+ #~(lambda (running)
+ (perform-service-action (lookup-service 'masquerade)
+ 'masquerade-off))))
+ (shepherd-action
+ (name 'masquerade-on)
+ (documentation "Turn on NAT masquerading.")
+ (procedure
+ #~(lambda (running)
+ (fork+exec-command (list
+ "/bin/sh"
+ "-c"
+ (string-append
+ #$herd-path
+ " "
+ "-s"
+ " "
+ #$socket-path
+ " "
+ "burn-state"
+ " "
+ "physical-dev-rw"
+ " "
+ "$("
+ #$ip-exec
+ " route | "
+ #$sed-exec
+ " -n '/^default/ "
+ "s=.*dev \\(.*\\)$=\\1=p'"
+ ") $("
+ #$ip-exec
+ " route | "
+ #$sed-exec
+ " -n '/^default/ "
+ "s=.*via "
+ "\\([^ ]\\+\\).*$=\\1=p'"
+ ")"
+ " "
+ "&&"
+ " "
+ #$iptables-exec
+ " "
+ "-v"
+ " "
+ "-t"
+ " "
+ "nat"
+ " "
+ "-A"
+ " "
+ "POSTROUTING"
+ " "
+ "-o"
+ " "
+ "$("
+ #$herd-path
+ " "
+ "-s"
+ " "
+ #$socket-path
+ " "
+ "display-physical-interface-name"
+ " "
+ "physical-dev-rw"
+ ")"
+ " "
+ "-j"
+ " "
+ "MASQUERADE"))))))
+ (shepherd-action
+ (name 'masquerade-off)
+ (documentation "Turn off NAT masquerading.")
+ (procedure
+ #~(lambda (running)
+ (fork+exec-command (list
+ "/bin/sh"
+ "-c"
+ (string-append
+ #$iptables-exec
+ " "
+ "-v"
+ " "
+ "-t"
+ " "
+ "nat"
+ " "
+ "-D"
+ " "
+ "POSTROUTING"
+ " "
+ "-o"
+ " "
+ "$("
+ #$herd-path
+ " "
+ "-s"
+ " "
+ #$socket-path
+ " "
+ "display-physical-interface-name"
+ " "
+ "physical-dev-rw"
+ ")"
+ " "
+ "-j"
+ " "
+ "MASQUERADE")))))))))
+
+(define (server-tun-actions config tun-int server-ip client-ip)
+ "Returns a list of shepherd actions for the whispers service
+reprensenting the tun device of a VPN server whose number is the integer
+TUN-INT, whose ip address is the string SERVER-IP and whose peer address
+is the string CLIENT-IP, configurable by CONFIG, a record of the
+<whispers-vpn-configuration> type."
+ (let* ((tun-str (tun-dev-str tun-int))
+ (tun-sym (tun-dev-sym tun-int))
+ (ip-package (whispers-vpn-configuration-iproute-package config))
+ (ip-exec (file-append ip-package
+ "/sbin/ip")))
+ (list (shepherd-action
+ (name 'start-tun)
+ (documentation (string-append "Start the TUN device service"
+ tun-str
+ "."))
+ (procedure
+ #~(lambda (running)
+ (start '#$tun-sym))))
+ (shepherd-action
+ (name 'stop-tun)
+ (documentation (string-append "Stop the TUN device service"
+ tun-str
+ "."))
+ (procedure
+ #~(lambda (running)
+ (stop-service (lookup-service '#$tun-sym)))))
+ (shepherd-action
+ (name 'pre-start)
+ (documentation (string-append "Create the TUN device service"
+ tun-str
+ "."))
+ (procedure
+ #~(lambda (running)
+ (fork+exec-command (list "/bin/sh"
+ "-c"
+ (string-append #$ip-exec
+ " "
+ "tuntap"
+ " "
+ "add"
+ " "
+ #$tun-str
+ " "
+ "mode"
+ " "
+ "tun"
+ " "
+ "user"
+ " "
+ "whispers"
+ " "
+ "group"
+ " "
+ "whispers"
+ " "
+ "&&"
+ " "
+ #$ip-exec
+ " "
+ "addr"
+ " "
+ "add"
+ " "
+ #$server-ip
+ "/32"
+ " "
+ "peer"
+ " "
+ #$client-ip
+ " "
+ "dev"
+ " "
+ #$tun-str
+ " "
+ "&&"
+ " "
+ #$ip-exec
+ " "
+ "link"
+ " "
+ "set"
+ " "
+ #$tun-str
+ " "
+ "up"))))))
+ (shepherd-action
+ (name 'post-stop)
+ (documentation (string-append "Delete the TUN device service"
+ tun-str
+ "."))
+ (procedure
+ #~(lambda (running)
+ (fork+exec-command (list "/bin/sh"
+ "-c"
+ (string-append #$ip-exec
+ " "
+ "link"
+ " "
+ "set"
+ " "
+ #$tun-str
+ " "
+ "down"
+ " "
+ ";"
+ " "
+ #$ip-exec
+ " "
+ "addr"
+ " "
+ "del"
+ " "
+ #$server-ip
+ "/32"
+ " "
+ "peer"
+ " "
+ #$client-ip
+ " "
+ "dev"
+ " "
+ #$tun-str
+ " "
+ ";"
+ " "
+ #$ip-exec
+ " "
+ "tuntap"
+ " "
+ "del"
+ " "
+ #$tun-str
+ " "
+ "mode"
+ " "
+ "tun")))))))))
+
+(define physical-dev-state-write-actions
+ (list (shepherd-action
+ (name 'burn-state)
+ (documentation "unload the existing instance of the
+'physical-dev-state service. Write a physical device state as a new
+service with the string PHY-DEV-NAME recorded in its
+'physical-interface-name action and the string ROUTER-IP recorded in its
+'physical-gateway-ip action.")
+ (procedure
+ #~(lambda (running phy-dev-name router-ip)
+ (perform-service-action (lookup-service 'root)
+ 'unload
+ "physical-dev-state")
+ (display "Burning new 'physical-dev-state service.\n")
+ (register-services
+ (make <service>
+ #:provides '(physical-dev-state)
+ #:start (lambda whatever #f)
+ #:stop (lambda whatever #t)
+ #:actions (make-actions
+ (physical-interface-name
+ "Return the name of the physical
+interface which supported
+the default route when
+the VPN was disconnected."
+ (lambda (running) phy-dev-name))
+ (physical-gateway-ip
+ "Return the ip of the gateway
+of the physical interface
+which supported the default
+route when the VPN was
+disconnected."
+ (lambda (running) router-ip)))
+ #:docstring "Queryable physical network device
+restoration state of a
+Whispers VPN."
+ #:one-shot? #t)))))))
+
+(define physical-dev-resolve-actions
+ (list (shepherd-action
+ (name 'display-physical-interface-name)
+ (documentation "For debugging purposes, display
+the name of the physical
+interface which supported
+the default route when
+the VPN was disconnected.")
+ (procedure
+ #~(lambda (running)
+ (display (perform-service-action (lookup-service
+ 'physical-dev-rw)
+ 'physical-interface-name)))))
+ (shepherd-action
+ (name 'physical-interface-name)
+ (documentation "Return the name of the physical
+interface which supported
+the default route when
+the VPN was disconnected.")
+ (procedure
+ #~(lambda (running)
+ (perform-service-action (lookup-service 'physical-dev-state)
+ 'physical-interface-name))))
+ (shepherd-action
+ (name 'display-physical-gateway-ip)
+ (documentation "For debugging purposes, display the ip of the
+gateway of the physical interface
+which supported the default
+route when the VPN was
+disconnected.")
+ (procedure
+ #~(lambda (running)
+ (display (perform-service-action (lookup-service
+ 'physical-dev-rw)
+ 'physical-gateway-ip)))))
+ (shepherd-action
+ (name 'physical-gateway-ip)
+ (documentation "Return the ip of the gateway
+of the physical interface
+which supported the default
+route when the VPN was
+disconnected.")
+ (procedure
+ #~(lambda (running)
+ (perform-service-action (lookup-service 'physical-dev-state)
+ 'physical-gateway-ip))))))
+
+(define (physical-dev-guessing-actions config)
+ "Return a list of shepherd actions used while the VPN is disconnected in
+order to guess the name of the default network interface that should
+support the VPN tunnel, and the IP address of its
+gateway. Afternatively, user configurations are used instead if the user
+has overriden the guessing by setting switches in CONFIG, a record of
+the <whispers-vpn-configuration> type."
+ (list (shepherd-action
+ (name 'guess-interface)
+ (documentation "Burn strings into the physical-dev-state
+service as the guesses of the name and gateway address of the physical
+interface which supports the default route when the VPN is
+disconnected. Then pass the hand to another shell through the VPN
+service to finish routing the connection.")
+ (procedure
+ (let* ((client-tun (whispers-vpn-configuration-client-tun-device
+ config))
+ (client-tun-str (tun-dev-str client-tun))
+ (phy-override?
+ (whispers-vpn-configuration-manual-physical-if? config))
+ (phy-override
+ (whispers-vpn-configuration-physical-if-override
+ config))
+ (ip-package (whispers-vpn-configuration-iproute-package
+ config))
+ (ip-exec (file-append ip-package
+ "/sbin/ip"))
+ (sed-package (whispers-vpn-configuration-sed-package
+ config))
+ (sed-exec (file-append sed-package
+ "/bin/sed"))
+ (herd-path "/run/current-system/profile/bin/herd")
+ (socket-path "/run/whispers/vpn/unix-sockets/vpn.sock"))
+ #~(lambda (running)
+ (if #$phy-override?
+ #$phy-override
+ (fork+exec-command
+ (list "/bin/sh"
+ "-c"
+ (string-append #$herd-path
+ " "
+ "-s"
+ " "
+ #$socket-path
+ " "
+ "burn-state"
+ " "
+ "physical-dev-rw"
+ " "
+ "$("
+ #$ip-exec
+ " route | "
+ #$sed-exec
+ " -n '/^default/ "
+ "s=.*dev \\(.*\\)$=\\1=p'"
+ ") $("
+ #$ip-exec
+ " route | "
+ #$sed-exec
+ " -n '/^default/ "
+ "s=.*via "
+ "\\([^ ]\\+\\).*$=\\1=p'"
+ ")"
+ " "
+ "&&"
+ " "
+ #$herd-path
+ " "
+ "-s"
+ " "
+ #$socket-path
+ " "
+ "tun-route"
+ " "
+ #$client-tun-str))))))))))
+
+(define (client-tun-actions config)
+ "Returns a list of shepherd actions for the whispers service
+reprensenting the tun device of a connected client, configurable by
+CONFIG, a record of the <whispers-vpn-configuration> type."
+ (let* ((client-tun (whispers-vpn-configuration-client-tun-device config))
+ (client-tun-str (tun-dev-str client-tun))
+ (client-tun-sym (tun-dev-sym client-tun))
+ (ip-package (whispers-vpn-configuration-iproute-package config))
+ (stealth? (whispers-vpn-configuration-stealth? config))
+ (proxy-ip (whispers-vpn-configuration-proxy-sshd-host config))
+ (server-ip (whispers-vpn-configuration-server-sshd-host
+ config))
+ (via-phy (if stealth?
+ proxy-ip
+ server-ip))
+ (phys-if #~(perform-service-action (lookup-service 'physical-dev-rw)
+ 'physical-interface-name))
+ (gate #~(perform-service-action (lookup-service 'physical-dev-rw)
+ 'physical-gateway-ip))
+ (ip-exec (file-append ip-package
+ "/sbin/ip")))
+ (list (shepherd-action
+ (name 'start-tun)
+ (documentation (string-append "Start the TUN device "
+ client-tun-str
+ "."))
+ (procedure
+ #~(lambda (running)
+ (start '#$client-tun-sym))))
+ (shepherd-action
+ (name 'stop-tun)
+ (documentation (string-append "Stop the TUN device "
+ client-tun-str
+ "."))
+ (procedure
+ #~(lambda (running)
+ (stop-service (lookup-service '#$client-tun-sym)))))
+ (shepherd-action
+ (name 'tun-route)
+ (documentation "Establish network address and routing rules
+for a newly connected client.")
+ (procedure
+ #~(lambda (running)
+ (let* ((client-ip (perform-service-action (lookup-service
+ 'network-rw)
+ 'hostname->ip
+ (gethostname)))
+ (server-ip (perform-service-action (lookup-service
+ 'network-rw)
+ 'hostname->server-ip
+ (gethostname)))
+ (server-ip-stripped
+ (regexp-substitute
+ #f
+ (string-match "([0-9]+\\.[0-9]+\\.[0-9]+)\\.[0-9]+"
+ server-ip)
+ 1
+ ".0")))
+ (fork+exec-command
+ (list "/bin/sh"
+ "-c"
+ (string-append #$ip-exec
+ " "
+ "route"
+ " "
+ "save"
+ " "
+ "&&"
+ " "
+ #$ip-exec
+ " "
+ "addr"
+ " "
+ "add"
+ " "
+ client-ip
+ " "
+ "peer"
+ " "
+ server-ip
+ " "
+ "dev"
+ " "
+ #$client-tun-str
+ " "
+ "&&"
+ " "
+ #$ip-exec
+ " "
+ "link"
+ " "
+ "set"
+ " "
+ #$client-tun-str
+ " "
+ "up"
+ " "
+ "&&"
+ " "
+ #$ip-exec
+ " "
+ "route"
+ " "
+ "del"
+ " "
+ "default"
+ " "
+ "&&"
+ " "
+ #$ip-exec
+ " "
+ "route"
+ " "
+ "add"
+ " "
+ #$via-phy
+ " "
+ "via"
+ " "
+ #$gate
+ " "
+ "dev"
+ " "
+ #$phys-if
+ " "
+ "&&"
+ " "
+ #$ip-exec
+ " "
+ "route"
+ " "
+ "add"
+ " "
+ server-ip-stripped
+ "/24"
+ " "
+ "via"
+ " "
+ server-ip
+ " "
+ "dev"
+ " "
+ #$client-tun-str
+ " "
+ "&&"
+ " "
+ #$ip-exec
+ " "
+ "route"
+ " "
+ "add"
+ " "
+ "default"
+ " "
+ "via"
+ " "
+ server-ip
+ " "
+ "dev"
+ " "
+ #$client-tun-str)))))))
+ (shepherd-action
+ (name 'pre-start)
+ (documentation "Burn relevant data about the physical network
+interface, then establish network address and routing rules for a newly
+connected client.")
+ (procedure
+ #~(lambda (running)
+ (perform-service-action (lookup-service 'physical-dev-rw)
+ 'guess-interface))))
+ (shepherd-action
+ (name 'post-stop)
+ (documentation "Restore default routing to its previous
+pre-connection state.")
+ (procedure
+ #~(lambda (running)
+ (let ((client-ip (perform-service-action (lookup-service
+ 'network-rw)
+ 'hostname->ip
+ (gethostname)))
+ (server-ip (perform-service-action (lookup-service
+ 'network-rw)
+ 'hostname->server-ip
+ (gethostname))))
+ (fork+exec-command
+ (list "/bin/sh"
+ "-c"
+ (string-append
+ ;; #$ip-exec
+ ;; " "
+ ;; "link"
+ ;; " "
+ ;; "set"
+ ;; " "
+ ;; #$client-tun-str
+ ;; " "
+ ;; "down"
+ ;; " "
+ ;; "&&"
+ ;; " "
+ ;; #$ip-exec
+ ;; " "
+ ;; "addr"
+ ;; " "
+ ;; "del"
+ ;; " "
+ ;; client-ip
+ ;; " "
+ ;; "peer"
+ ;; " "
+ ;; server-ip
+ ;; " "
+ ;; "dev"
+ ;; " "
+ ;; #$client-tun-str
+ ;; " "
+ ;; "&&"
+ ;; " "
+ ;; #$ip-exec
+ ;; " "
+ ;; "route"
+ ;; " "
+ ;; "del"
+ ;; " "
+ ;; "default"
+ ;; " "
+ ;; "&&"
+ ;; " "
+ #$ip-exec
+ " "
+ "route"
+ " "
+ "del"
+ " "
+ #$via-phy
+ " "
+ "via"
+ " "
+ #$gate
+ " "
+ "dev"
+ " "
+ #$phys-if
+ " "
+ "&&"
+ " "
+ #$ip-exec
+ " "
+ "route"
+ " "
+ "add"
+ " "
+ "default"
+ " "
+ "via"
+ " "
+ #$gate
+ " "
+ "dev"
+ " "
+ #$phys-if))))))))))
+
+(define (tcp-ip-actions config)
+ "Returns a list of shepherd actions for the lieutenants of the 'vpn
+service handling tun devices, configurable by CONFIG, a record of the
+<whispers-vpn-configuration> type."
+ (let* ((client? (whispers-vpn-configuration-client? config))
+ (empty-net (empty-network (whispers-vpn-configuration-constants
+ config)))
+ (client-tun (whispers-vpn-configuration-client-tun-device config))
+ (client-tun-sym (tun-dev-sym client-tun))
+ (client-tun-str (symbol->string client-tun-sym))
+ (voucher->tun-int (lambda (voucher)
+ (cadar (filter (lambda (field)
+ (equal? (car field)
+ 'tun-device-number))
+ voucher))))
+ (voucher->tun-str (lambda (voucher)
+ (tun-dev-str (voucher->tun-int voucher))))
+ (masquerade? (whispers-vpn-configuration-masquerade? config)))
+ (if client?
+ (list (shepherd-action
+ (name (string->symbol (string-append "start-"
+ client-tun-str)))
+ (documentation (string-append "Start the client-side TUN
+interface "
+ client-tun-str
+ "."))
+ (procedure
+ #~(lambda (running)
+ (perform-service-action
+ (lookup-service 'vpn)
+ 'lieutenant-action
+ "start-tun"
+ #$client-tun-str))))
+ (shepherd-action
+ (name (string->symbol
+ (string-append "stop-"
+ client-tun-str)))
+ (documentation (string-append "Stop the client-side TUN
+interface "
+ client-tun-str
+ "."))
+ (procedure
+ #~(lambda (running)
+ (perform-service-action
+ (lookup-service 'vpn)
+ 'lieutenant-action
+ "stop-tun"
+ #$client-tun-str)))))
+ (append
+ (map (lambda (voucher)
+ (shepherd-action
+ (name (string->symbol
+ (string-append "start-"
+ (voucher->tun-str voucher))))
+ (documentation (string-append "Start the server-side
+TUN interface "
+ (voucher->tun-str voucher)
+ "."))
+ (procedure
+ #~(lambda (running)
+ (perform-service-action
+ (lookup-service '#$(string->symbol
+ (voucher->tun-str voucher)))
+ 'start-tun)))))
+ empty-net)
+ (map (lambda (voucher)
+ (shepherd-action
+ (name (string->symbol
+ (string-append "stop-"
+ (voucher->tun-str voucher))))
+ (documentation (string-append "Stop the server-side TUN
+interface "
+ (voucher->tun-str voucher)
+ "."))
+ (procedure
+ #~(lambda (running)
+ (perform-service-action
+ (lookup-service '#$(string->symbol
+ (voucher->tun-str voucher))))
+ 'stop-tun))))
+ empty-net)))))
+
+(define (physical-dev-rw-shepherd-services config)
+ "Returns a list of one <shepherd-service> object providing actions to
+infer, read and write the physical interface device state stored in the
+'physical-dev-state service in its scope, configurable by CONFIG, a
+record of the <whishpers-vpn-configuration> type. Data about the
+physical interface default route is retrievable from this service to
+support the establishement of interface addresses and routing rules
+during connection and disconnection of a client from the VPN."
+ (list (shepherd-service
+ (documentation "Physical-Dev state read and write operations.")
+ (provision '(physical-dev-rw))
+ (requirement '())
+ (start #~(lambda config #f))
+ (actions (append physical-dev-state-write-actions
+ physical-dev-resolve-actions
+ (physical-dev-guessing-actions config)))
+ (stop #~(lambda config #t))
+ (one-shot? #t)
+ (auto-start? #f))))
+
+(define physical-dev-rw-service-type
+ (service-type
+ (name 'physical-dev-rw)
+ (description "Shepherd service used for read and write operations of
+the physical-dev state of a Whispers VPN.")
+ (extensions
+ (list (service-extension shepherd-root-service-type
+ physical-dev-rw-shepherd-services)))
+ (default-value (whispers-vpn-configuration))))
+
+(define (physical-dev-state-shepherd-services whatever)
+ "Returns a list of one <shepherd-service> object doing nothing of
+interest in the state in which it is instanciated at guix's system
+reconfigure time, not configurable by WHATEVER. While a VPN client will
+be connecting at the OS run-time, the characteristics of the physical
+network interface will be inferred and burned into a modified
+re-instanciated version of this service."
+ (list (shepherd-service
+ (documentation "Queryable physical-dev state of a Whispers VPN.")
+ (provision '(physical-dev-state))
+ (requirement '())
+ (start #~(lambda whatever #f))
+ (actions
+ (list (shepherd-action
+ (name 'physical-interface-name)
+ (documentation "Does not return anything of interest at
+this time.")
+ (procedure #~(lambda (running) "Unknown.")))
+ (shepherd-action
+ (name 'physical-gateway-ip)
+ (documentation "Does not return anything of interest at
+this time.")
+ (procedure #~(lambda (running) "Unknown.")))))
+ (stop #~(lambda whatever #t))
+ (one-shot? #t)
+ (auto-start? #f))))
+
+(define physical-dev-state-service-type
+ (service-type
+ (name 'physical-dev-state)
+ (description "Shepherd service used for storage and retrieval of the
+physical-dev state of a Whispers VPN.")
+ (extensions
+ (list (service-extension shepherd-root-service-type
+ physical-dev-state-shepherd-services)))
+ (default-value 'whatever)))
+
+(define (server-tcp-ip-lieutenant voucher config)
+ "Returns a whispers lieutenant handling a VPN-server-side tun device
+as defined by the voucher data VOUCHER, configurable by CONFIG, a record
+of the <whispers-vpn-configuration> type."
+ (let* ((tun-int (cadar (filter (lambda (field)
+ (equal? (car field)
+ 'tun-device-number))
+ voucher)))
+ (server-ip (cadar (filter (lambda (field)
+ (equal? (car field)
+ 'server-ip))
+ voucher)))
+ (client-ip (cadar (filter (lambda (field)
+ (equal? (car field)
+ 'client-ip))
+ voucher)))
+ (tun-str (tun-dev-str tun-int))
+ (tun-sym (tun-dev-sym tun-int))
+ (masquerade? (whispers-vpn-configuration-masquerade? config))
+ (ipv4-forw? (whispers-vpn-configuration-ipv4-ip-forward? config)))
+ (service whispers-service-type
+ (whispers-configuration
+ (name tun-sym)
+ (requires (append (if masquerade?
+ '(masquerade)
+ '())
+ (if ipv4-forw?
+ '(ipv4-ip-forward)
+ '())))
+ (extra-packages (list iproute
+ iptables))
+ (pre-start-action? #t)
+ (post-stop-action? #t)
+ (extra-actions (server-tun-actions config
+ tun-int
+ server-ip
+ client-ip))
+ (%auto-start? #f)))))
+
+(define (tcp-ip-lieutenants config)
+ "Returns a list of lieutenants of the 'vpn service for handling the hair
+around tun devices, configurable by CONFIG, a record of the
+<whispers-vpn-configuration> type."
+ (let* ((client? (whispers-vpn-configuration-client? config))
+ (client-tun (whispers-vpn-configuration-client-tun-device config))
+ (client-dev (tun-dev-sym client-tun))
+ (constants (whispers-vpn-configuration-constants config)))
+ (append (list (service physical-dev-rw-service-type config)
+ (service physical-dev-state-service-type 'whatever))
+ (if client?
+ (list
+ (service whispers-service-type
+ (whispers-configuration
+ (name client-dev)
+ (requires '(registered))
+ (pre-start-action? #t)
+ (post-stop-action? #t)
+ (extra-actions (client-tun-actions config))
+ (%auto-start? #f))))
+ (append (map (lambda (voucher)
+ (server-tcp-ip-lieutenant voucher config))
+ (empty-network constants))
+ (list (service whispers-service-type
+ (whispers-configuration
+ (name 'masquerade)
+ (requires '())
+ (pre-start-action? #t)
+ (post-stop-action? #t)
+ (extra-actions (masquerade-actions
+ config))
+ (%auto-start? #f)))
+ (service whispers-service-type
+ (whispers-configuration
+ (name 'ipv4-ip-forward)
+ (requires '())
+ (pre-start-action? #t)
+ (post-stop-action? #t)
+ (extra-actions (ipv4-forward-actions
+ config))
+ (%auto-start? #f)))))))))
+
+(define want-connect-state-write-actions
+ (list (shepherd-action
+ (name 'want-connect-on)
+ (documentation "Activate the connection status wish of a VPN
+client by burning a new 'want-connect-state service with a #t action
+return value.")
+ (procedure
+ #~(lambda (running)
+ (perform-service-action (lookup-service 'want-connect-rw)
+ 'burn-state
+ #t))))
+ (shepherd-action
+ (name 'want-connect-off)
+ (documentation "Disactivate the connection status wish of a VPN
+client by burning a new 'want-connect-state service with a #f action
+return value.")
+ (procedure
+ #~(lambda (running)
+ (perform-service-action (lookup-service 'want-connect-rw)
+ 'burn-state
+ #f))))
+ (shepherd-action
+ (name 'burn-state)
+ (documentation "unload the existing instance of the
+'want-connect-state service. Write a connection status wish as a new
+service with the boolean value WANT? recorded in its 'want-connect?
+action.")
+ (procedure
+ #~(lambda (running want?)
+ (when (lookup-service 'want-connect-state)
+ (perform-service-action (lookup-service 'root)
+ 'unload
+ "want-connect-state"))
+ (display "Burning new 'want-connect-state service.\n")
+ (register-services
+ (make <service>
+ #:provides '(want-connect-state)
+ #:start (lambda whatever #f)
+ #:stop (lambda whatever #t)
+ #:actions (make-actions
+ (want-connect?
+ "Return the connection status wish of a
+VPN client. The returned boolean value is used only at the end of client
+registration, to determine if connection is to be performed
+auto-immedately."
+ (lambda (running) want?)))
+ #:docstring "Queryable connection status wish state of a
+Whispers VPN."
+ #:one-shot? #t)))))))
+
+(define want-connect-resolve-actions
+ (list (shepherd-action
+ (name 'display-want-connect?)
+ (documentation "For debugging purposes, display the connection
+status wish of a VPN client.")
+ (procedure
+ #~(lambda (running)
+ (display (perform-service-action (lookup-service
+ 'want-connect-rw)
+ 'want-connect?)))))
+ (shepherd-action
+ (name 'want-connect?)
+ (documentation "Return the connection status wish of a
+VPN client.The returned boolean value is used only at the end of client
+registration, to determine if connection is to be performed
+auto-immedately.")
+ (procedure
+ #~(lambda (running)
+ (if (lookup-service 'want-connect-state)
+ (perform-service-action (lookup-service
+ 'want-connect-state)
+ 'want-connect?)
+ #f))))))
+
+(define voucher-resolve-actions
+ (list
+ (shepherd-action
+ (name 'field-value->voucher)
+ (documentation "Returns a voucher whose field symbol FIELD has the
+string value VALUE, #f if no voucher is found.")
+ (procedure
+ #~(lambda (running field value)
+ ((lambda (lst) (if (null? lst) #f (car lst)))
+ (filter (lambda (voucher)
+ (and (not (null?
+ (filter (lambda (entry)
+ (and (equal? (car entry)
+ field)
+ (equal? (cadr entry)
+ value)))
+ voucher)))))
+ (perform-service-action (lookup-service 'network-rw)
+ 'network-state))))))
+ (shepherd-action
+ (name 'voucher-field->value)
+ (documentation "Returns the string value of the field symbol FIELD
+of the voucher list of pairs VOUCHER, or #f if the voucher has no such
+field.")
+ (procedure
+ #~(lambda (running field voucher)
+ ((lambda (lst)
+ (if (null? lst)
+ #f
+ (cadr (car lst)))) (filter (lambda (entry)
+ (equal? (car entry)
+ field))
+ voucher)))))
+ (shepherd-action
+ (name 'display-unknown-host?)
+ (documentation "For debugging purposes, display #f if the host named
+by the string HOSTNAME has a booked vouched, #t otherwise.")
+ (procedure
+ #~(lambda (running hostname)
+ (display (perform-service-action (lookup-service 'network-rw)
+ 'unknown-host?
+ hostname)))))
+ (shepherd-action
+ (name 'unknown-host?)
+ (documentation "Returns #f if the host named by the string HOSTNAME
+has a booked vouched, #t otherwise.")
+ (procedure
+ #~(lambda (running hostname)
+ (not (perform-service-action (lookup-service 'network-rw)
+ 'field-value->voucher
+ 'client-hostname
+ hostname)))))
+ (shepherd-action
+ (name 'display-hostname->tun-request?)
+ (documentation "For debugging purposes, display a predicate true if
+the client named by the string HOSTNAME is a known connected client
+according to the current network state.")
+ (procedure
+ #~(lambda (running hostname)
+ (display (car (perform-service-action (lookup-service 'network-rw)
+ 'hostname->tun-request?
+ hostname))))))
+ (shepherd-action
+ (name 'hostname->tun-request?)
+ (documentation "Returns a predicate true if the client named by the
+string HOSTNAME is a known connected client according to the current
+network state.")
+ (procedure
+ #~(lambda (running hostname)
+ (unless (perform-service-action (lookup-service 'network-rw)
+ 'unknown-host?
+ hostname)
+ (display "known host voucher: ")
+ (display (perform-service-action (lookup-service 'network-rw)
+ 'field-value->voucher
+ 'client-hostname
+ hostname))
+ (display "\n")
+ (perform-service-action (lookup-service 'network-rw)
+ 'voucher-field->value
+ 'tun-request?
+ (perform-service-action
+ (lookup-service
+ 'network-rw)
+ 'field-value->voucher
+ 'client-hostname
+ hostname))))))
+ (shepherd-action
+ (name 'display-hostname->connected?)
+ (documentation "For debugging purposes, display a predicate true if
+the client named by the string HOSTNAME is a known connected client
+according to the current network state.")
+ (procedure
+ #~(lambda (running hostname)
+ (display (perform-service-action (lookup-service 'network-rw)
+ 'hostname->connected?
+ hostname)))))
+ (shepherd-action
+ (name 'hostname->connected?)
+ (documentation "Returns a predicate true if the client named by the
+string HOSTNAME is a known connected client according to the current
+network state.")
+ (procedure
+ #~(lambda (running hostname)
+ (unless (perform-service-action (lookup-service 'network-rw)
+ 'unknown-host?
+ hostname)
+ (display "known host voucher: ")
+ (display (perform-service-action (lookup-service 'network-rw)
+ 'field-value->voucher
+ 'client-hostname
+ hostname))
+ (display "\n")
+ (perform-service-action (lookup-service 'network-rw)
+ 'voucher-field->value
+ 'connected?
+ (perform-service-action
+ (lookup-service 'network-rw)
+ 'field-value->voucher
+ 'client-hostname
+ hostname))))))
+ (shepherd-action
+ (name 'display-hostname->ip)
+ (documentation "Display the client IP address of the host HOSTNAME if
+it has booked a voucher, #f otherwise.")
+ (procedure
+ #~(lambda (running hostname)
+ (display (perform-service-action (lookup-service 'network-rw)
+ 'hostname->ip
+ hostname)))))
+ (shepherd-action
+ (name 'hostname->ip)
+ (documentation "Returns the client IP address of the host HOSTNAME if
+it has booked a voucher, #f otherwise.")
+ (procedure
+ #~(lambda (running hostname)
+ (if (perform-service-action (lookup-service 'network-rw)
+ 'unknown-host?
+ hostname)
+ #f
+ (perform-service-action (lookup-service 'network-rw)
+ 'voucher-field->value
+ 'client-ip
+ (perform-service-action
+ (lookup-service
+ 'network-rw)
+ 'field-value->voucher
+ 'client-hostname
+ hostname))))))
+ (shepherd-action
+ (name 'display-hostname->server-ip)
+ (documentation "Display the server IP address of the host HOSTNAME if
+it has booked a voucher, #f otherwise.")
+ (procedure
+ #~(lambda (running hostname)
+ (display (perform-service-action (lookup-service 'network-rw)
+ 'hostname->server-ip
+ hostname)))))
+ (shepherd-action
+ (name 'hostname->server-ip)
+ (documentation "Returns the server IP address of the host HOSTNAME if
+it has booked a voucher, #f otherwise.")
+ (procedure
+ #~(lambda (running hostname)
+ (if (perform-service-action (lookup-service 'network-rw)
+ 'unknown-host?
+ hostname)
+ #f
+ (perform-service-action (lookup-service 'network-rw)
+ 'voucher-field->value
+ 'server-ip
+ (perform-service-action
+ (lookup-service
+ 'network-rw)
+ 'field-value->voucher
+ 'client-hostname
+ hostname))))))
+ (shepherd-action
+ (name 'hostname->port)
+ (documentation "Returns the port number of the reverse port
+forwarding open to the ssh daemon of the host HOSTNAME if it has booked
+a voucher, #f otherwise.")
+ (procedure
+ #~(lambda (running hostname)
+ (if (perform-service-action (lookup-service 'network-rw)
+ 'unknown-host?
+ hostname)
+ #f
+ (perform-service-action (lookup-service 'network-rw)
+ 'voucher-field->value
+ 'reverse-port
+ (perform-service-action
+ (lookup-service
+ 'network-rw)
+ 'field-value->voucher
+ 'client-hostname
+ hostname))))))
+ (shepherd-action
+ (name 'hostname->tun)
+ (documentation "Returns the tun device number of the tunnel forward
+opened by the ssh daemon of the host HOSTNAME if it has booked a
+voucher, #f otherwise.")
+ (procedure
+ #~(lambda (running hostname)
+ (if (perform-service-action (lookup-service 'network-rw)
+ 'unknown-host?
+ hostname)
+ #f
+ (perform-service-action (lookup-service 'network-rw)
+ 'voucher-field->value
+ 'tun-device-number
+ (perform-service-action
+ (lookup-service
+ 'network-rw)
+ 'field-value->voucher
+ 'client-hostname
+ hostname))))))))
+
+(define (client->server-actions config)
+ "Returns a list of <shepherd-action> records defining actions that the
+VPN clients use to execute commands as the unpriviledged whispers user
+of the server, configurable by CONFIG, a record of the
+<whispers-vpn-configuration> type."
+ (list
+ (shepherd-action
+ (name 'set-disconnected-knock)
+ (documentation "Set the 'connected? field of the local client's
+voucher to #f in the server's network states and knock-knock the
+server. The server then propagates to the whole network.")
+ (procedure
+ (let* ((herd-path "/run/current-system/profile/bin/herd")
+ (base-socket-path "/run/whispers/vpn")
+ (unpriv-sock (string-append
+ base-socket-path
+ "/unpriviledged/unix-sockets/unpriviledged.sock")))
+ #~(lambda (running)
+ (perform-service-action (lookup-service 'network-rw)
+ 'server-command-knock
+ (string-append #$herd-path
+ " "
+ "-s"
+ " "
+ #$unpriv-sock
+ " "
+ "set-disconnected"
+ " "
+ "network-rw"
+ " "
+ (gethostname)))))))
+ (shepherd-action
+ (name 'set-connected-knock)
+ (documentation "Set the 'connected? field of the local client's
+voucher to #t in the server's unpriviledged network state, set the
+'tun-request? field of the local client's voucher to #f in the server's
+unpriviledged network state, and knock-knock the server. The server then
+propagates to the whole network.")
+ (procedure
+ (let* ((herd-path "/run/current-system/profile/bin/herd")
+ (base-socket-path "/run/whispers/vpn")
+ (unpriv-sock (string-append
+ base-socket-path
+ "/unpriviledged/unix-sockets/unpriviledged.sock")))
+ #~(lambda (running)
+ (perform-service-action (lookup-service 'network-rw)
+ 'server-command-knock
+ (string-append #$herd-path
+ " "
+ "-s"
+ " "
+ #$unpriv-sock
+ " "
+ "set-connected"
+ " "
+ "network-rw"
+ " "
+ (gethostname)
+ " "
+ "&&"
+ " "
+ #$herd-path
+ " "
+ "-s"
+ " "
+ #$unpriv-sock
+ " "
+ "unset-tun-request"
+ " "
+ "network-rw"
+ " "
+ (gethostname)))))))
+ (shepherd-action
+ (name 'set-tun-request-knock)
+ (documentation "Set the 'tun-request? field of the local client's
+voucher to #t in the server's network states, then knock-knock the
+server. The server then creates a TUN interface for the local client.")
+ (procedure
+ (let* ((herd-path "/run/current-system/profile/bin/herd")
+ (base-socket-path "/run/whispers/vpn")
+ (unpriv-sock (string-append
+ base-socket-path
+ "/unpriviledged/unix-sockets/unpriviledged.sock")))
+ #~(lambda (running)
+ (perform-service-action (lookup-service 'network-rw)
+ 'server-command-knock
+ (string-append #$herd-path
+ " "
+ "-s"
+ " "
+ #$unpriv-sock
+ " "
+ "set-tun-request"
+ " "
+ "network-rw"
+ " "
+ (gethostname)))))))
+ (shepherd-action
+ (name 'server-command-knock)
+ (documentation "Execute the string COMMAND as a shell command as the
+unpriviledges whispers user of the server, then knock-knock the server.")
+ (procedure
+ (let* ((ssh-package (whispers-vpn-configuration-ssh-package config))
+ (forward-port (whispers-vpn-configuration-forward-port config))
+ (forward-port-str (number->string forward-port))
+ (herd-path "/run/current-system/profile/bin/herd")
+ (base-socket-path "/run/whispers/vpn")
+ (knocker-socket (string-append
+ base-socket-path
+ "/knocker/unix-sockets/knocker.sock")))
+ #~(lambda (running command)
+ (fork+exec-command (list #$(file-append ssh-package
+ "/bin/ssh")
+ "-o"
+ "StrictHostKeyChecking=no"
+ "-o"
+ "UserKnownHostsFile=/dev/null"
+ "-p"
+ #$forward-port-str
+ "whispers@localhost"
+ (string-append command
+ " "
+ "&&"
+ " "
+ #$herd-path
+ " "
+ "-s"
+ " "
+ #$knocker-socket
+ " "
+ "stop"
+ " "
+ "root")))))))
+ (shepherd-action
+ (name 'book)
+ (documentation "Book a voucher for this client's hostname in the
+server's unpriviledge network state, then knock-knock the server to
+propagate to the whole network.")
+ (procedure
+ (let* ((herd-path "/run/current-system/profile/bin/herd")
+ (base-socket-path "/run/whispers/vpn")
+ (unpriv-sock (string-append
+ base-socket-path
+ "/unpriviledged/unix-sockets/unpriviledged.sock")))
+ #~(lambda (running)
+ (perform-service-action (lookup-service 'network-rw)
+ 'server-command-knock
+ (string-append #$herd-path
+ " "
+ "-s"
+ " "
+ #$unpriv-sock
+ " "
+ "book-client"
+ " "
+ "network-rw"
+ " "
+ (gethostname)))))))
+ (shepherd-action
+ (name 'free)
+ (documentation "Free this client's hostname voucher in the server's
+unpriviledge network state, then knock-knock the server to propagate to
+the whole network.")
+ (procedure
+ (let* ((herd-path "/run/current-system/profile/bin/herd")
+ (base-socket-path "/run/whispers/vpn")
+ (unpriv-sock (string-append
+ base-socket-path
+ "/unpriviledged/unix-sockets/unpriviledged.sock")))
+ #~(lambda (running)
+ (perform-service-action (lookup-service 'network-rw)
+ 'server-command-knock
+ (string-append #$herd-path
+ " "
+ "-s"
+ " "
+ #$unpriv-sock
+ " "
+ "free-client-booking"
+ " "
+ "network-rw"
+ " "
+ (gethostname)))))))
+ (shepherd-action
+ (name 'complete-handshake)
+ (documentation "Complete a handshake with the VPN server by
+registering, unregistering or disconnecting this machine as a client.")
+ (procedure
+ (let* ((herd-path "/run/current-system/profile/bin/herd")
+ (base-socket-path "/run/whispers/vpn")
+ (vpn-sock (string-append
+ base-socket-path
+ "/unix-sockets/vpn.sock")))
+ #~(lambda (running)
+ (cond ((service-running? (lookup-service 'registering))
+ (perform-service-action (lookup-service 'network-rw)
+ 'book))
+ ((service-running? (lookup-service 'unregistering))
+ (perform-service-action (lookup-service 'network-rw)
+ 'free))
+ ((service-running? (lookup-service 'disconnecting))
+ (fork+exec-command (list #$herd-path
+ "-s"
+ #$vpn-sock
+ "set-disconnected-knock"
+ "network-rw"))))))))))
+
+(define (server->client-actions config)
+ "Returns a list of <shepherd-action> records defining actions that the
+VPN server uses to execute commands as the unpriviledged whispers user
+of its clients, configurable by CONFIG, a record of the
+<whispers-vpn-configuration> type."
+ (list
+ (shepherd-action
+ (name 'knock-knock-client)
+ (documentation "Duplicate the server network state in the
+unpriviledged vpn/unpriviledged Whispers lieutenant the client defined
+by the string CLIENT-SPEC, then knock-knock this client. CLIENT-SPEC is
+parsed as follows:
+- When CLIENT-SPEC is the string \"in-handshake\", the client is
+whichever provisional client has grabbed the handshake port of the
+server. Presumably this client has just booked a voucher in the server's
+network state.
+- When CLIENT-SPEC is a string of the form \"client/HOSTNAME\", the
+client is the connected client whose hostname is HOSTNAME.
+- Other CLIENT-SPEC strings have no effect")
+ (procedure
+ (let* ((ssh-package (whispers-vpn-configuration-ssh-package config))
+ (constants (whispers-vpn-configuration-constants config))
+ (handshake-port (network-constants-handshake-port constants))
+ (handshake-port-str (number->string handshake-port))
+ (herd-path "/run/current-system/profile/bin/herd")
+ (base-socket-path "/run/whispers/vpn")
+ (unpriv-sock (string-append
+ base-socket-path
+ "/unpriviledged/unix-sockets/unpriviledged.sock"))
+ (knocker-socket (string-append
+ base-socket-path
+ "/knocker/unix-sockets/knocker.sock")))
+ #~(lambda (running client-spec)
+ (let ((client-reverse-port
+ (cond ((equal? client-spec "in-handshake")
+ #$handshake-port-str)
+ ((equal? (substring client-spec 0 7)
+ "client/")
+ (number->string (perform-service-action
+ (lookup-service
+ 'network-rw)
+ 'hostname->port
+ (substring client-spec
+ 7))))
+ (#t "ssh-please-fail"))))
+ (let ((new-state (perform-service-action (lookup-service
+ 'network-rw)
+ 'print-network-state)))
+ (fork+exec-command
+ (list #$(file-append ssh-package
+ "/bin/ssh")
+ "-p"
+ client-reverse-port
+ "-o"
+ "StrictHostKeyChecking=no"
+ "-o"
+ "UserKnownHostsFile=/dev/null"
+ "whispers@localhost"
+ (string-append #$herd-path
+ " "
+ "-s"
+ " "
+ #$unpriv-sock
+ " "
+ "read-network-state"
+ " "
+ "network-rw"
+ " "
+ "'"
+ new-state
+ "'"
+ " "
+ "&&"
+ " "
+ #$herd-path
+ " "
+ "-s"
+ " "
+ #$knocker-socket
+ " "
+ "stop"
+ " "
+ "root")))))))))
+ (shepherd-action
+ (name 'knock-knock-connected-clients)
+ (documentation "From the server, knock-knock all registered and
+connected clients.")
+ (procedure
+ #~(lambda (running)
+ (map (lambda (voucher)
+ (when (and (perform-service-action (lookup-service
+ 'network-rw)
+ 'voucher-field->value
+ 'client-hostname
+ voucher)
+ (perform-service-action (lookup-service
+ 'network-rw)
+ 'hostname->connected?
+ (perform-service-action
+ (lookup-service
+ 'network-rw)
+ 'voucher-field->value
+ 'client-hostname
+ voucher)))
+ (let ((client-host (perform-service-action
+ (lookup-service
+ 'network-rw)
+ 'voucher-field->value
+ 'client-hostname
+ voucher)))
+ (display (string-append "Client "
+ client-host
+ " is connected, "
+ "knock-knock.\n"))
+ (perform-service-action (lookup-service 'network-rw)
+ 'knock-knock-client
+ (string-append "client/"
+ client-host)))))
+ (perform-service-action (lookup-service 'network-rw)
+ 'network-state)))))
+ (shepherd-action
+ (name 'knock-knock-clients)
+ (documentation "From the server, knock-knock the whole accessible
+client network from. First knock-knock a prospective client performing a
+handshake, then knock-knock all registered and connected clients.")
+ (procedure
+ #~(lambda (running)
+ (display "knock-knock into the handshake reverse forward.\n")
+ (perform-service-action (lookup-service 'network-rw)
+ 'knock-knock-client
+ "in-handshake")
+ (display "knock-knock all connected clients.\n")
+ (perform-service-action (lookup-service 'network-rw)
+ 'knock-knock-connected-clients))))))
+
+(define voucher-actions
+ (list
+ (shepherd-action
+ (name 'book-lowest-voucher)
+ (documentation "Return a list of vouchers in which the string
+HOSTNAME has been booked the lowest voucher-number available voucher in
+the voucher list VOUCHERS. Using this action interactively can result in
+the same client being booked twice.")
+ (procedure
+ #~(lambda (running hostname vouchers)
+ (if (not (null? ((lambda (voucher)
+ (filter (lambda (entry)
+ (and (equal? (car entry)
+ 'client-hostname)
+ (equal? (cadr entry)
+ #f)))
+ voucher)) (car vouchers))))
+ (cons (map (lambda (entry)
+ (if (equal? (car entry)
+ 'client-hostname)
+ `(client-hostname ,hostname)
+ entry))
+ (car vouchers))
+ (cdr vouchers))
+ (cons (car vouchers)
+ (perform-service-action (lookup-service 'network-rw)
+ 'book-lowest-voucher
+ hostname
+ (cdr vouchers)))))))
+ (shepherd-action
+ (name 'add-unbooked-client)
+ (documentation "Return VOUCHERS if the string HOSTNAME is already
+booked in the list of vouchers VOUCHERS. Otherwise, return a list of
+vouchers in which HOSTNAME has been booked the lowest voucher-number
+available voucher in VOUCHERS.")
+ (procedure
+ #~(lambda (running hostname vouchers)
+ (display "Client: ")
+ (display hostname)
+ (display " is requesting a new voucher.\n")
+ (if (perform-service-action (lookup-service 'network-rw)
+ 'unknown-host?
+ hostname)
+ (begin (display (string-append
+ "Booking a new voucher for client "
+ hostname
+ ".\n"))
+ (perform-service-action (lookup-service 'network-rw)
+ 'book-lowest-voucher
+ hostname
+ vouchers))
+ (begin (display (string-append
+ "Client "
+ hostname
+ " already booked, not booking.\n"))
+ vouchers)))))
+ (shepherd-action
+ (name 'book-client)
+ (documentation "Book a new client by burning a new list of vouchers
+into a new 'network-state service, where a new voucher has been booked
+to HOSTNAME if HOSTNAME is not already booked.")
+ (procedure
+ #~(lambda (running hostname)
+ (perform-service-action (lookup-service 'network-rw)
+ 'burn-state
+ (perform-service-action
+ (lookup-service 'network-rw)
+ 'add-unbooked-client
+ hostname
+ (perform-service-action
+ (lookup-service 'network-rw)
+ 'network-state))))))
+ (shepherd-action
+ (name 'free-voucher)
+ (documentation "Return a list of vouchers in which the voucher
+recording HOSTNAME as its 'client-hostname field has been replaced by a
+free voucher.")
+ (procedure
+ #~(lambda (running hostname vouchers)
+ (if (not (null? ((lambda (voucher)
+ (filter (lambda (entry)
+ (and (equal? (car entry)
+ 'client-hostname)
+ (equal? (cadr entry)
+ hostname)))
+ voucher)) (car vouchers))))
+ (cons (map (lambda (entry)
+ (if (equal? (car entry)
+ 'client-hostname)
+ '(client-hostname #f)
+ entry))
+ (car vouchers))
+ (cdr vouchers))
+ (cons (car vouchers)
+ (perform-service-action (lookup-service 'network-rw)
+ 'free-voucher
+ hostname
+ (cdr vouchers)))))))
+ (shepherd-action
+ (name 'remove-booked-client)
+ (documentation "Return VOUCHERS if the string HOSTNAME is not booked
+in the list of vouchers VOUCHERS. Otherwise, return a list of vouchers
+in which the voucher recording HOSTNAME as its 'client-hostname field
+has been replaced by a free voucher.")
+ (procedure
+ #~(lambda (running hostname vouchers)
+ (display "Client: ")
+ (display hostname)
+ (display " is requesting freeing his voucher.\n")
+ (if (perform-service-action (lookup-service 'network-rw)
+ 'unknown-host?
+ hostname)
+ (begin (display (string-append
+ "Client "
+ hostname
+ " is not booked, not freeing.\n"))
+ vouchers)
+ (begin (display (string-append
+ "Freeing voucher of client "
+ hostname
+ ".\n"))
+ (perform-service-action (lookup-service 'network-rw)
+ 'free-voucher
+ hostname
+ vouchers))))))
+ (shepherd-action
+ (name 'free-client-booking)
+ (documentation "Burn a new list of vouchers in which the voucher of
+the client whose hostname is the string HOSTNAME has been replaced by a
+unbooked voucher.")
+ (procedure
+ #~(lambda (running hostname)
+ (perform-service-action (lookup-service 'network-rw)
+ 'burn-state
+ (perform-service-action
+ (lookup-service 'network-rw)
+ 'remove-booked-client
+ hostname
+ (perform-service-action
+ (lookup-service 'network-rw)
+ 'network-state))))))
+ (shepherd-action
+ (name 'tun-request!)
+ (documentation "Return a list of vouchers equal to the list of
+vouchers VOUCHERS in which the 'tun-request? field of the voucher of the
+client whose hostname is the string HOSTNAME has been set to the boolean
+value NEW-STATUS.")
+ (procedure
+ #~(lambda (running hostname new-status vouchers)
+ (if (not (null? ((lambda (voucher)
+ (filter (lambda (entry)
+ (and (equal? (car entry)
+ 'client-hostname)
+ (equal? (cadr entry)
+ hostname)))
+ voucher)) (car vouchers))))
+ (cons (map (lambda (entry)
+ (if (equal? (car entry)
+ 'tun-request?)
+ `(tun-request? ,new-status)
+ entry))
+ (car vouchers))
+ (cdr vouchers))
+ (cons (car vouchers)
+ (perform-service-action (lookup-service 'network-rw)
+ 'tun-request!
+ hostname
+ new-status
+ (cdr vouchers)))))))
+ (shepherd-action
+ (name 'tun-request!-maybe)
+ (documentation "Return VOUCHERS if the string HOSTNAME is not booked
+in the list of vouchers VOUCHERS. Otherwise, return a list of vouchers
+in which the 'tun-request? field of the voucher recording HOSTNAME as its
+'client-hostname field has been set to the boolean value NEW-STATUS.")
+ (procedure
+ #~(lambda (running hostname new-status vouchers)
+ (display "Client: ")
+ (display hostname)
+ (display " is requesting a change of requestor status.\n")
+ (if (perform-service-action (lookup-service 'network-rw)
+ 'unknown-host?
+ hostname)
+ (begin (display (string-append
+ "Client "
+ hostname
+ " is not booked, not proceeding.\n"))
+ vouchers)
+ (begin (display (string-append
+ "Setting requestor status of client "
+ hostname
+ " to "
+ (if new-status "true" "false")
+ ".\n"))
+ (perform-service-action (lookup-service 'network-rw)
+ 'tun-request!
+ hostname
+ new-status
+ vouchers))))))
+ (shepherd-action
+ (name 'set-tun-request)
+ (documentation "Burn a new list of vouchers in which the
+'tun-request? field of the voucher of the client whose hostname is the
+string HOSTNAME has been set to #t.")
+ (procedure
+ #~(lambda (running hostname)
+ (perform-service-action (lookup-service 'network-rw)
+ 'burn-state
+ (perform-service-action
+ (lookup-service 'network-rw)
+ 'tun-request!-maybe
+ hostname
+ #t
+ (perform-service-action
+ (lookup-service 'network-rw)
+ 'network-state))))))
+ (shepherd-action
+ (name 'unset-tun-request)
+ (documentation "Burn a new list of vouchers in which the
+'tun-request? field of the voucher of the client whose hostname is the
+string HOSTNAME has been set to #f.")
+ (procedure
+ #~(lambda (running hostname)
+ (perform-service-action (lookup-service 'network-rw)
+ 'burn-state
+ (perform-service-action
+ (lookup-service 'network-rw)
+ 'tun-request!-maybe
+ hostname
+ #f
+ (perform-service-action
+ (lookup-service 'network-rw)
+ 'network-state))))))
+ (shepherd-action
+ (name 'connected!)
+ (documentation "Return a list of vouchers equal to the list of
+vouchers VOUCHERS in which the 'connected? field of the voucher of the
+client whose hostname is the string HOSTNAME has been set to the boolean
+value NEW-STATUS.")
+ (procedure
+ #~(lambda (running hostname new-status vouchers)
+ (if (not (null? ((lambda (voucher)
+ (filter (lambda (entry)
+ (and (equal? (car entry)
+ 'client-hostname)
+ (equal? (cadr entry)
+ hostname)))
+ voucher)) (car vouchers))))
+ (cons (map (lambda (entry)
+ (if (equal? (car entry)
+ 'connected?)
+ `(connected? ,new-status)
+ entry))
+ (car vouchers))
+ (cdr vouchers))
+ (cons (car vouchers)
+ (perform-service-action (lookup-service 'network-rw)
+ 'connected!
+ hostname
+ new-status
+ (cdr vouchers)))))))
+ (shepherd-action
+ (name 'connected!-maybe)
+ (documentation "Return VOUCHERS if the string HOSTNAME is not booked
+in the list of vouchers VOUCHERS. Otherwise, return a list of vouchers
+in which the 'connected? field of the voucher recording HOSTNAME as its
+'client-hostname field has been set to the boolean value NEW-STATUS.")
+ (procedure
+ #~(lambda (running hostname new-status vouchers)
+ (display "Client: ")
+ (display hostname)
+ (display " is requesting a change of connection status.\n")
+ (if (perform-service-action (lookup-service 'network-rw)
+ 'unknown-host?
+ hostname)
+ (begin (display (string-append
+ "Client "
+ hostname
+ " is not booked, not proceeding.\n"))
+ vouchers)
+ (begin (display (string-append
+ "Setting connection status of client "
+ hostname
+ " to "
+ (if new-status "true" "false")
+ ".\n"))
+ (perform-service-action (lookup-service 'network-rw)
+ 'connected!
+ hostname
+ new-status
+ vouchers))))))
+ (shepherd-action
+ (name 'set-connected)
+ (documentation "Burn a new list of vouchers in which the 'conencted?
+field of the voucher of the client whose hostname is the string HOSTNAME
+has been set to #t.")
+ (procedure
+ #~(lambda (running hostname)
+ (perform-service-action (lookup-service 'network-rw)
+ 'burn-state
+ (perform-service-action
+ (lookup-service 'network-rw)
+ 'connected!-maybe
+ hostname
+ #t
+ (perform-service-action
+ (lookup-service
+ 'network-rw)
+ 'network-state))))))
+ (shepherd-action
+ (name 'set-disconnected)
+ (documentation "Burn a new list of vouchers in which the 'connected
+field of the voucher of the client whose hostname is the string HOSTNAME
+has been set to #f.")
+ (procedure
+ #~(lambda (running hostname)
+ (perform-service-action (lookup-service 'network-rw)
+ 'burn-state
+ (perform-service-action
+ (lookup-service 'network-rw)
+ 'connected!-maybe
+ hostname
+ #f
+ (perform-service-action
+ (lookup-service 'network-rw)
+ 'network-state))))))))
+
+(define (knocker-actions config)
+ "Returns a list of <shepherd-actions> objects for the 'knocker
+lieutenant of the 'vpn whispers lieutenant, configurable by CONFIG, a
+record of the <whispers-vpn-configuration> type."
+ (list (shepherd-action
+ (name 'pre-start)
+ (documentation "Perform the 'knock-knock action of the 'knocker
+service.")
+ (procedure
+ #~(lambda (running)
+ (perform-service-action (lookup-service 'knocker)
+ 'knock-knock))))
+ (shepherd-action
+ (name 'knock-knock)
+ (documentation "Burn the network state recorded in lieutenant
+service into the 'network-state service at this level of the whispers
+tree. Then:
+- VPN clients perform the following in order:
+ - Stop the 'handshake-port-forward persistent ssh connection.
+ - Check if the client's own hostname has a connected status in the
+local network state and perform the following:
+ - If yes, start the 'connected lieutenant of the 'vpn service
+and stop the 'disconnected lieutenant of the 'vpn service.
+ - if no, start the 'disconnected lieutenant of the 'vpn service
+and stop the 'connected lieutenant of the 'vpn service.
+ - Check if the client's own hostname is a known host in the
+local network state and perform the following:
+ - If yes, start the 'registered lieutenant of the 'vpn service,
+stop the 'unregistered lieutenant of the 'vpn service and chain connect
+auto-immediately if appropriate per the boolean value recorded in the
+'want-connect-state lieutenant.
+ - if no, start the 'unregistered lieutenant of the 'vpn service
+and stop the 'registered lieutenant of the 'vpn service.
+ - If the local client has no voucher associated to its host name or
+if it has a voucher whose 'tun-request? field is value is #f, stop the
+'connecting lieutenant of the 'vpn service and stop the 'disconnecting
+lieutenant of the 'vpn service.
+ - If the local client's voucher's 'tun-request? field evaluates to a
+true value, start the persistent ssh connection supporting the tunnel
+forward of the local client.
+ - Stop the 'registering and 'unregistering lieutenants
+of the 'vpn service.
+- The VPN server performs either of the following:
+ - If the network state contains one or more vouchers whose
+'tun-request? field evaluates to a true value, perform either one of the
+following for each of the clients whose hostname is resolved by the
+aforementioned vouchers:
+ - If the 'connected? field of the voucher evaluates to a true
+value, perform the following in order:
+ - Destroy the server-side TUN interface of this voucher by
+stopping the corresponding lieutenant of the 'vpn service.
+ - Knock-knock the client of this voucher.
+ - Set the 'tun-request? field of this voucher to #f in the
+network state.
+ - If the 'connected? field of the voucher evaluates to #f value,
+perform the following in order:
+ - Create the server-side TUN interface of this voucher by
+starting the corresponding lieutenant of the 'vpn service.
+ - Knock-knock the client of this voucher.
+ - Set the 'tun-request? field of this voucher to #f in the
+network state.
+ - Otherwise, knock-knock all clients, including a prospective
+client through the handshake reverse forward.")
+ (procedure
+ (let* ((client? (whispers-vpn-configuration-client? config))
+ (herd-path "/run/current-system/profile/bin/herd")
+ (handshake-conf (handshake-forward-configuration config))
+ (handshake-name (persistent-ssh-name handshake-conf)))
+ #~(lambda (running)
+ (display "Who's there?\n")
+ (perform-service-action (lookup-service 'network-rw)
+ 'burn-state
+ (perform-service-action
+ (lookup-service 'network-rw)
+ 'lieutenant-network-state))
+ (let* ((state (perform-service-action (lookup-service
+ 'network-rw)
+ 'network-state))
+ (req-field? (lambda (field)
+ (equal? (car field)
+ 'tun-request?)))
+ (requester? (lambda (voucher)
+ (cadar (filter req-field?
+ voucher))))
+ (requesters (filter requester?
+ state))
+ (con-field? (lambda (field)
+ (equal? (car field)
+ 'connected?)))
+ (con? (lambda (voucher)
+ (cadar (filter con-field?
+ voucher))))
+ (host-field? (lambda (field)
+ (equal? (car field)
+ 'client-hostname)))
+ (host (lambda (voucher)
+ (cadar (filter host-field?
+ voucher))))
+ (tun-num-f? (lambda (field)
+ (equal? (car field)
+ 'tun-device-number)))
+ (tun-num (lambda (voucher)
+ (cadar (filter tun-num-f?
+ voucher))))
+ (tun-str (lambda (voucher)
+ (string-append
+ "tun"
+ (number->string (tun-num
+ voucher)))))
+ (tun-sym (lambda (voucher)
+ (string->symbol (tun-str
+ voucher))))
+ (tun-act (lambda (voucher)
+ (if (con? voucher)
+ 'stop-tun
+ 'start-tun))))
+ (if (not #$client?)
+ (if (null? requesters)
+ (perform-service-action (lookup-service
+ 'network-rw)
+ 'knock-knock-clients)
+ (begin (map (lambda (voucher)
+ (perform-service-action
+ (lookup-service (tun-sym voucher))
+ (tun-act voucher)))
+ requesters)
+ (map (lambda (voucher)
+ (perform-service-action
+ (lookup-service 'network-rw)
+ 'knock-knock-client
+ (string-append "client/"
+ (host
+ voucher))))
+ requesters)
+ (map (lambda (voucher)
+ (perform-service-action
+ (lookup-service 'network-rw)
+ 'unset-tun-request
+ (host voucher)))
+ requesters)))
+ (begin (stop-service (lookup-service
+ '#$handshake-name))
+ (if (perform-service-action
+ (lookup-service 'network-rw)
+ 'hostname->connected?
+ (gethostname))
+ (begin (start-service (lookup-service
+ 'connected))
+ (stop-service (lookup-service
+ 'disconnected)))
+ (begin (start-service (lookup-service
+ 'disconnected))
+ (stop-service (lookup-service
+ 'connected))))
+ (if (perform-service-action (lookup-service
+ 'network-rw)
+ 'unknown-host?
+ (gethostname))
+ (begin (start-service (lookup-service
+ 'unregistered))
+ (stop-service (lookup-service
+ 'registered)))
+ (begin (start-service (lookup-service
+ 'registered))
+ (stop-service (lookup-service
+ 'unregistered))
+ (perform-service-action
+ (lookup-service 'registering)
+ 'maybe-chain-conn)))
+ (when (or (perform-service-action
+ (lookup-service 'network-rw)
+ 'unknown-host?
+ (gethostname))
+ (not (perform-service-action
+ (lookup-service 'network-rw)
+ 'hostname->tun-request?
+ (gethostname))))
+ (stop-service (lookup-service 'connecting))
+ (stop-service (lookup-service
+ 'disconnecting)))
+ (when (and (not (perform-service-action
+ (lookup-service 'network-rw)
+ 'unknown-host?
+ (gethostname)))
+ (perform-service-action
+ (lookup-service
+ 'network-rw)
+ 'hostname->tun-request?
+ (gethostname)))
+ (perform-service-action (lookup-service
+ 'connecting)
+ 'tun-start-ssh))
+ (stop-service (lookup-service 'registering))
+ (stop-service (lookup-service
+ 'unregistering)))))))))))
+
+(define network-state-rw-actions
+ (list (shepherd-action
+ (name 'burn-state)
+ (documentation "unload the existing instance of the
+'network-state service. Write a network state NEW-STATE as the content
+of a new instance of the 'network-state service, from there on queryable
+through its 'vouchers action.")
+ (procedure
+ #~(lambda (running . new-state)
+ (perform-service-action (lookup-service 'root)
+ 'unload
+ "network-state")
+ (display "Burning new 'network-state service.\n")
+ (register-services
+ (make <service>
+ #:provides '(network-state)
+ #:start (lambda whatever #f)
+ #:stop (lambda whatever #t)
+ #:actions (make-actions
+ (vouchers
+ "Return the network state stored in the
+service."
+ (lambda (running) (car new-state))))
+ #:docstring "Queryable network state of a Whispers VPN."
+ #:one-shot? #t)))))
+ (shepherd-action
+ (name 'network-state)
+ (documentation "Return the list of vouchers returned by the
+'vouchers action of the 'network-state service in scope at the current
+level of the whispers tree.")
+ (procedure
+ #~(lambda (running)
+ (perform-service-action (lookup-service 'network-state)
+ 'vouchers))))
+ (shepherd-action
+ (name 'read-network-state)
+ (documentation "Burn the string NEW-STATE as it is read by the
+read syntax as the new network state of the 'network-state service.")
+ (procedure
+ #~(lambda (running . new-state)
+ (perform-service-action (lookup-service 'network-rw)
+ 'burn-state
+ (with-input-from-string (car new-state)
+ read)))))
+ (shepherd-action
+ (name 'print-network-state)
+ (documentation "Return the network state as a string which can
+be read by the 'read-network-state action of another shepherd's
+'network-rw Whispers lieutenant service's read-network-state action.")
+ (procedure
+ #~(lambda (running)
+ (with-output-to-string (lambda ()
+ (write (perform-service-action
+ (lookup-service 'network-rw)
+ 'network-state)))))))
+ (shepherd-action
+ (name 'display-network-state)
+ (documentation "For debugging puposes, display to standard
+output the list of vouchers returned by the 'vouchers action of the
+'network-state service in scope at current level of the whispers tree.")
+ (procedure
+ #~(lambda (running)
+ (map (lambda (voucher)
+ (display voucher)
+ (display "\n"))
+ (perform-service-action (lookup-service 'network-rw)
+ 'network-state)))))
+ (shepherd-action
+ (name 'lieutenant-network-state)
+ (documentation "Return the list of vouchers returned by the
+'vouchers action of the 'network-state service in scope in scope of the
+'unpriviledged lieutenant whispers shepherd.")
+ (procedure
+ #~(lambda (running)
+ (perform-service-action (lookup-service 'unpriviledged)
+ 'lieutenant-action
+ "network-state"
+ "network-rw"))))
+ (shepherd-action
+ (name 'display-lieutenant-network-state)
+ (documentation "For debugging puposes, display to standard
+output the list of vouchers returned by the 'vouchers action of the
+'network-state service in scope of the 'unpriviledged lieutenant
+whispers shepherd.")
+ (procedure
+ #~(lambda (running)
+ (map (lambda (voucher)
+ (display voucher)
+ (display "\n"))
+ (perform-service-action
+ (display-network-state 'network-rw)
+ 'lieutenant-network-state)))))))
+
+(define (want-connect-rw-shepherd-services whatever)
+ "Returns a list of one <shepherd-service> object providing actions to
+read and write the connection status wish of a client under registration.
+from a 'want-connect-state service in its scope, not configurable by
+WHATEVER."
+ (list (shepherd-service
+ (documentation "connection status wish state read and write
+operations.")
+ (provision '(want-connect-rw))
+ (requirement '())
+ (start #~(lambda whatever #f))
+ (actions (append want-connect-state-write-actions
+ want-connect-resolve-actions))
+ (stop #~(lambda whatever #t))
+ (one-shot? #t)
+ (auto-start? #f))))
+
+(define want-connect-rw-service-type
+ (service-type
+ (name 'want-connect-rw)
+ (description "Shepherd service used for read and write operations of
+the want-connect state of a Whispers VPN.")
+ (extensions
+ (list (service-extension shepherd-root-service-type
+ want-connect-rw-shepherd-services)))
+ (default-value (whispers-vpn-configuration))))
+
+(define (want-connect-state-shepherd-services whatever)
+ "Returns a list of one <shepherd-service> object doing nothing of
+interest in the state in which it is instanciated at guix's system
+reconfigure time, not configurable by WHATEVER. While a VPN client will
+be registering at the OS run-time, the final connection status wished by
+the client (connected or registered only) will be stored in and
+retrievable from the service."
+ (list (shepherd-service
+ (documentation "Queryable connection status wish state of a
+Whispers VPN.")
+ (provision '(want-connect-state))
+ (requirement '())
+ (start #~(lambda whatever #f))
+ (actions
+ (list (shepherd-action
+ (name 'want-connect?)
+ (documentation "Does not return anything of interest at
+this time, nor have any side effects.")
+ (procedure #~(lambda (running) #f)))))
+ (stop #~(lambda whatever #t))
+ (one-shot? #t)
+ (auto-start? #f))))
+
+(define want-connect-state-service-type
+ (service-type
+ (name 'want-connect-state)
+ (description "Shepherd service used for storage and retrieval of the
+current status wish of a VPN client under registration: connected or
+registered only.")
+ (extensions
+ (list (service-extension shepherd-root-service-type
+ want-connect-state-shepherd-services)))
+ (default-value 'whatever)))
+
+(define (network-rw-shepherd-services config)
+ "Returns a list of one <shepherd-service> object providing actions to
+read and write the network state stored in the 'network-state service in
+its scope,configurable by CONFIG, a record of the
+<whispers-vpn-configuration> type."
+ (let ((client? (whispers-vpn-configuration-client? config)))
+ (list (shepherd-service
+ (documentation "Network state read and write operations.")
+ (provision '(network-rw))
+ (requirement '())
+ (start #~(lambda whatever #f))
+ (actions (append network-state-rw-actions
+ voucher-resolve-actions
+ (if client?
+ (client->server-actions config)
+ (append voucher-actions
+ (server->client-actions config)))))
+ (stop #~(lambda whatever #t))
+ (one-shot? #t)
+ (auto-start? #f)))))
+
+(define network-rw-service-type
+ (service-type
+ (name 'network-rw)
+ (description "Shepherd service used for read and write operations of
+the network state of a Whispers VPN.")
+ (extensions
+ (list (service-extension shepherd-root-service-type
+ network-rw-shepherd-services)))
+ (default-value (whispers-vpn-configuration))))
+
+(define (network-state-shepherd-services network-state)
+ "Returns a list of one <shepherd-service> object storing the list of
+vouchers NETWORK-STATE in the return value of its 'vouchers shepherd
+action."
+ (list (shepherd-service
+ (documentation "Queryable network state of a Whispers VPN.")
+ (provision '(network-state))
+ (requirement '())
+ (start #~(lambda whatever #f))
+ (actions
+ (list (shepherd-action
+ (name 'vouchers)
+ (documentation "Return the network state stored in the
+service.")
+ (procedure #~(lambda (running) '#$network-state)))))
+ (stop #~(lambda whatever #t))
+ (one-shot? #t)
+ (auto-start? #f))))
+
+(define network-state-service-type
+ (service-type
+ (name 'network-state)
+ (description "Shepherd service used for storage and retrieval of the
+network state of a Whispers VPN.")
+ (extensions
+ (list (service-extension shepherd-root-service-type
+ network-state-shepherd-services)))
+ (default-value (network-constants))))
+
+(define (state-services config)
+ "Returns a list of 2 shepherd root Guix services which do not
+daemonize any process, a service to perform read and write action on a
+network state, and a service to store a mutbable network state,
+configurable by CONFIG, a record of the <whispers-vpn-configuration>
+type."
+ (list (service network-state-service-type
+ (empty-network (whispers-vpn-configuration-constants
+ config)))
+ (service network-rw-service-type config)))
+
+(define (vpn-lieutenants config)
+ "Returns the list of the lieutenants of the 'vpn service sitting at
+the top of the whispers sub-tree of a Whispers VPN, configurable by
+CONFIG, a record of the <whispers-vpn-configuration> type."
+ (let* ((client? (whispers-vpn-configuration-client? config))
+ (auto-register? (whispers-vpn-configuration-auto-register? config)))
+ (append
+ (if client?
+ (let* ((forward-conf (forward-configuration config))
+ (forward-name (persistent-ssh-name forward-conf)))
+ (append
+ (map (lambda (service-config)
+ (service persistent-ssh-service-type service-config))
+ (reverse-forward-configurations config))
+ (map (lambda (service-config)
+ (service persistent-ssh-service-type service-config))
+ (tun-device-forward-configurations config))
+ (list (service persistent-ssh-service-type
+ (forward-configuration config))
+ (service persistent-ssh-service-type
+ (handshake-forward-configuration config))
+ (service whispers-service-type
+ (whispers-configuration
+ (name 'registering)
+ (requires (list forward-name))
+ (pre-start-action? #t)
+ (extra-actions (registering-actions config))
+ (%auto-start? auto-register?)))
+ (service whispers-service-type
+ (whispers-configuration
+ (name 'unregistering)
+ (requires (list forward-name))
+ (pre-start-action? #t)
+ (extra-actions (unregistering-actions config))
+ (%auto-start? #f)))
+ (service whispers-service-type
+ (whispers-configuration
+ (name 'registered)
+ (requires (list forward-name))
+ (%auto-start? #f)))
+ (service whispers-service-type
+ (whispers-configuration
+ (name 'unregistered)
+ (requires (list forward-name))
+ (%auto-start? #f)))
+ (service whispers-service-type
+ (whispers-configuration
+ (name 'connecting)
+ (requires (list forward-name
+ 'registered))
+ (pre-start-action? #t)
+ (extra-actions
+ (connecting-actions config))
+ (%auto-start? #f)))
+ (service whispers-service-type
+ (whispers-configuration
+ (name 'disconnecting)
+ (requires (list forward-name))
+ (pre-start-action? #t)
+ (extra-actions
+ (disconnecting-actions config))
+ (%auto-start? #f)))
+ (service whispers-service-type
+ (whispers-configuration
+ (name 'connected)
+ (requires (list forward-name
+ 'registered))
+ (extra-actions connected-actions)
+ (%auto-start? #f)))
+ (service whispers-service-type
+ (whispers-configuration
+ (name 'disconnected)
+ (requires (list forward-name))
+ (%auto-start? #f)))
+ (service want-connect-rw-service-type
+ 'whatever)
+ (service want-connect-state-service-type
+ 'whatever))))
+ (list))
+ (state-services config)
+ (list (service whispers-service-type
+ (whispers-configuration
+ (name 'unpriviledged)
+ (lieutenants (state-services config))
+ (user "whispers")
+ (extend-user? #t)
+ (group "whispers")
+ (extend-group? #t)))
+ (service whispers-service-type
+ (whispers-configuration
+ (name 'knocker)
+ (requires '(unpriviledged))
+ (pre-start-action? #t)
+ (user "whispers")
+ (group "whispers")
+ (extra-actions (knocker-actions config)))))
+ (tcp-ip-lieutenants config))))
+
+(define (vpn-actions config)
+ "Return the list of actions of the 'vpn service, configurable by
+CONFIG, a record of the <whispers-vpn-configuration> type."
+ (append
+ (list (shepherd-action
+ (name 'pre-start)
+ (documentation "Create the directories and tmpfs mounts used
+by the persistent ssh connections of the 'vpn service.")
+ (procedure
+ #~(lambda (running)
+ (perform-service-action (lookup-service 'vpn)
+ 'make-directory
+ "/var/log/whispers/vpn/ssh-tunneler"
+ "root"
+ "root"
+ #$(number->string #o755 8))
+ (perform-service-action (lookup-service 'vpn)
+ 'make-tmpfs
+ "/run/whispers/vpn/ssh-tunneler"
+ "root"
+ "root"
+ #$(number->string #o755 8)))))
+ (shepherd-action
+ (name 'post-stop)
+ (documentation "Unmount the tmpfs mounts used by the
+persistent ssh connections of the VPN service.")
+ (procedure
+ #~(lambda (running)
+ (perform-service-action (lookup-service 'vpn)
+ 'clear-tmpfs
+ "/run/whispers/vpn/ssh-tunneler"))))
+ (shepherd-action
+ (name 'register)
+ (documentation "Register this host in the VPN network.")
+ (procedure
+ #~(lambda (running)
+ (display (string-append "Client "
+ (gethostname)
+ " initiating register "
+ "sequence.\n"))
+ (if (perform-service-action (lookup-service 'vpn)
+ 'lieutenant-action
+ "running?"
+ "connected")
+ (begin (display "'connected lieutenant is ")
+ (display "started, register ")
+ (display "sequence canceled.\n"))
+ (begin (display "'connected lieutenant is ")
+ (display "not started, register ")
+ (display "sequence confirmed.\n")
+ (perform-service-action (lookup-service 'vpn)
+ 'lieutenant-action
+ "start-registering"
+ "registering"))))))
+ (shepherd-action
+ (name 'unregister)
+ (documentation "Unregister this host from the VPN network.")
+ (procedure
+ #~(lambda (running)
+ (display (string-append "Client "
+ (gethostname)
+ " initiating unregister "
+ "sequence.\n"))
+ (if (perform-service-action (lookup-service 'vpn)
+ 'lieutenant-action
+ "running?"
+ "connected")
+ (begin (display "'connected lieutenant is ")
+ (display "started, unregister ")
+ (display "sequence canceled.\n"))
+ (begin (display "'connected lieutenant is ")
+ (display "not started, unregister ")
+ (display "sequence confirmed.\n")
+ (perform-service-action (lookup-service 'vpn)
+ 'lieutenant-action
+ "start-unregistering"
+ "unregistering"))))))
+ (shepherd-action
+ (name 'connect)
+ (documentation "Connect this host in the VPN network.")
+ (procedure
+ #~(lambda (running)
+ (if (perform-service-action (lookup-service 'vpn)
+ 'lieutenant-action
+ "unknown-host?"
+ "network-rw"
+ (gethostname))
+ (begin (display (string-append "Client "
+ (gethostname)
+ " is not registered.\n"
+ "Initiating "
+ "regiseter-connect "
+ "sequence.\n"))
+ (perform-service-action (lookup-service 'vpn)
+ 'lieutenant-action
+ "want-connect-on"
+ "want-connect-rw")
+ (perform-service-action (lookup-service 'vpn)
+ 'register))
+ (begin (display (string-append "Client "
+ (gethostname)
+ " is already registered.\n"
+ "Initiating connect "
+ "sequence.\n"))
+ (if (perform-service-action (lookup-service 'vpn)
+ 'lieutenant-action
+ "running?"
+ "connected")
+ (begin (display "'connected lieutenant is ")
+ (display "started, connect ")
+ (display "sequence canceled.\n"))
+ (begin (display "'connected lieutenant is ")
+ (display "not started, connect ")
+ (display "sequence confirmed.\n")
+ (perform-service-action
+ (lookup-service 'vpn)
+ 'lieutenant-action
+ "start-connecting"
+ "connecting"))))))))
+ (shepherd-action
+ (name 'disconnect)
+ (documentation "Disconnect this host from the VPN network.")
+ (procedure
+ #~(lambda (running)
+ (display (string-append "Client "
+ (gethostname)
+ " initiating disconnect "
+ "sequence.\n"))
+ (if (perform-service-action (lookup-service 'vpn)
+ 'lieutenant-action
+ "running?"
+ "connected")
+ (begin (display "'connected lieutenant is ")
+ (display "started, disconnect ")
+ (display "sequence confirmed.\n")
+ (perform-service-action (lookup-service 'vpn)
+ 'lieutenant-action
+ "start-disconnecting"
+ "disconnecting"))
+ (begin (display "'connected lieutenant is ")
+ (display "not started, disconnect ")
+ (display "sequence canceled.\n")))))))
+ (tcp-ip-actions config)))
+
+(define (registering-actions config)
+ "Returns the list of actions of the 'registering lieutenant of the
+'vpn service, configurable by CONFIG, a record of the
+<whispers-vpn-configuration> type."
+ (list (shepherd-action
+ (name 'pre-start)
+ (documentation "Connect the handshake reverse port forward to
+the server, book a voucer in the server network state, knock-knock the
+server to propagate to the whole network, then terminate the handshake
+reverse port forward.")
+ (procedure
+ (let* ((handshake-conf (handshake-forward-configuration config))
+ (handshake-name (persistent-ssh-name handshake-conf)))
+ #~(lambda (running)
+ (start-in-the-background (list '#$handshake-name))))))
+ (shepherd-action
+ (name 'start-registering)
+ (documentation "Start the 'registering service")
+ (procedure
+ #~(lambda (running)
+ (start-service (lookup-service 'registering)))))
+ (shepherd-action
+ (name 'maybe-chain-conn)
+ (documentation "If the want-connect connection status wish is
+#t, reset it to #f and start connecting auto-immediately.")
+ (procedure
+ (let* ((herd-path "/run/current-system/profile/bin/herd")
+ (whisp-sock "/run/whispers/unix-sockets/whispers.sock"))
+ #~(lambda (running)
+ (if (or (not (lookup-service 'want-connect-rw))
+ (not (perform-service-action
+ (lookup-service 'want-connect-rw)
+ 'want-connect?))
+ (perform-service-action (lookup-service 'network-rw)
+ 'hostname->tun-request?
+ (gethostname)))
+ (display (string-append "Client "
+ (gethostname)
+ " not chain-connecting.\n"))
+ (begin (display (string-append "Client "
+ (gethostname)
+ " chain-connecting.\n"))
+ (perform-service-action (lookup-service
+ 'want-connect-rw)
+ 'want-connect-off)
+ ;; FIXME: action up the whispers tree, deadlock?
+ (fork+exec-command (list #$herd-path
+ "-s"
+ #$whisp-sock
+ "connect"
+ "vpn"))))))))))
+
+(define (unregistering-actions config)
+ "Returns the list of actions of the 'unregistering lieutenant of the
+'vpn service, configurable by CONFIG, a record of the
+<whispers-vpn-configuration> type."
+ (list (shepherd-action
+ (name 'pre-start)
+ (documentation "Connect the handshake reverse port forward to
+the server, book a voucer in the server network state, knock-knock the
+server to propagate to the whole network, then terminate the handshake
+reverse port forward.")
+ (procedure
+ (let* ((handshake-conf (handshake-forward-configuration config))
+ (handshake-name (persistent-ssh-name handshake-conf)))
+
+ #~(lambda (running)
+ (start-in-the-background (list '#$handshake-name))))))
+ (shepherd-action
+ (name 'start-unregistering)
+ (documentation "Start the 'unregistering service")
+ (procedure
+ #~(lambda (running)
+ (start-service (lookup-service 'unregistering)))))))
+
+(define connected-actions
+ (list (shepherd-action
+ (name 'running?)
+ (documentation "Return #t if the 'connected service is running,
+return #f it is stopped.")
+ (procedure
+ #~(lambda (running)
+ (service-running? (lookup-service 'connected)))))))
+
+(define (connecting-actions config)
+ "Return the list of actions of the 'connecting lieutenant of the 'vpn
+service, configurable by CONFIG, a record of the
+<whispers-vpn-configuration> type."
+ (let* ((herd-path "/run/current-system/profile/bin/herd")
+ (base-socket-path "/run/whispers/vpn")
+ (vpn-sock (string-append base-socket-path
+ "/unix-sockets/vpn.sock"))
+ (exit-port (whispers-vpn-configuration-client-sshd-port config))
+ (exit-str (number->string exit-port))
+ (client-tun (whispers-vpn-configuration-client-tun-device config))
+ (client-tun-str (number->string client-tun))
+ (stealth? (whispers-vpn-configuration-stealth? config))
+ (rev-stealth-conf (reverse-stealth-conf config))
+ (rev-stealth-forward (car (ssh-connection-configuration-forwards
+ rev-stealth-conf)))
+ (rev-stealth-port (ssh-forward-configuration-entry-port
+ rev-stealth-forward))
+ (rev-stealth-port-str (number->string rev-stealth-port))
+ (rev-stealth-stance (if stealth?
+ ;; FIXME: not future-proof
+ (string-append "_proxy-port_"
+ rev-stealth-port-str)
+ ""))
+ (tun-stealth-conf (tun-stealth-conf config))
+ (tun-stealth-forward (car (ssh-connection-configuration-forwards
+ tun-stealth-conf)))
+ (tun-stealth-port (ssh-forward-configuration-entry-port
+ tun-stealth-forward))
+ (tun-stealth-port-str (number->string tun-stealth-port))
+ (tun-stealth-stance (if stealth?
+ ;; FIXME: not future-proof
+ (string-append "_proxy-port_"
+ tun-stealth-port-str)
+ "")))
+ (list (shepherd-action
+ (name 'pre-start)
+ (documentation "Connect the handshake reverse port forward to
+the server, book a voucer in the server network state, knock-knock the
+server to propagate to the whole network, then terminate the handshake
+reverse port forward.")
+ (procedure
+ #~(lambda (running)
+ (let* ((server-port (perform-service-action
+ (lookup-service 'network-rw)
+ 'hostname->port
+ (gethostname)))
+ (server-port-str (number->string server-port))
+ ;; FIXME: not future-proof
+ (stance (string-append server-port-str
+ ":"
+ "127.0.0.1"
+ ":"
+ #$exit-str))
+ ;; FIXME: not future-proof
+ (name-str (string-append "ssh-forwards_reverse-port@"
+ stance
+ #$rev-stealth-stance))
+ (name-sym (string->symbol name-str)))
+ (display "Starting reverse port forwarding.\n")
+ (start-in-the-background (list name-sym))))))
+ (shepherd-action
+ (name 'tun-start-dev)
+ (documentation "Knock-knock the server to create the TUN
+network device on the server side.")
+ (procedure
+ #~(lambda (running)
+ (let* ((server-tun (perform-service-action
+ (lookup-service 'network-rw)
+ 'hostname->tun
+ (gethostname)))
+ (tun-str (number->string server-tun)))
+ (fork+exec-command (list #$herd-path
+ "-s"
+ #$vpn-sock
+ "set-tun-request-knock"
+ "network-rw"))))))
+ (shepherd-action
+ (name 'tun-start-ssh)
+ (documentation "Start the ssh persistent connection
+supporting the VPN tun device on client and server sides.")
+ (procedure
+ #~(lambda (running)
+ (let* ((server-tun (perform-service-action
+ (lookup-service 'network-rw)
+ 'hostname->tun
+ (gethostname)))
+ (server-tun-str (number->string server-tun))
+ (tun-str (number->string server-tun))
+ (stance (string-append #$client-tun-str
+ ":"
+ server-tun-str))
+ ;; FIXME: not future-proof
+ (name-str (string-append "ssh-forwards_tunnel@"
+ stance
+ #$tun-stealth-stance))
+ (name-sym (string->symbol name-str)))
+ (display (string-append "Starting "
+ name-str
+ " in the background.\n"))
+ (start-in-the-background (list name-sym))))))
+ (shepherd-action
+ (name 'start-connecting)
+ (documentation "Start the 'connecting service")
+ (procedure
+ #~(lambda (running)
+ (start-service (lookup-service 'connecting))))))))
+
+(define (disconnecting-actions config)
+ "Return the list of actions of the 'disconnecting lieutenant of the
+'vpn service, configurable by CONFIG, a record of the
+<whispers-vpn-configuration> type."
+ (let* ((client-tun (whispers-vpn-configuration-client-tun-device config))
+ (client-tun-str (number->string client-tun))
+ (exit-port (whispers-vpn-configuration-client-sshd-port config))
+ (exit-str (number->string exit-port))
+ (handshake-conf (handshake-forward-configuration config))
+ (handshake-name (persistent-ssh-name handshake-conf))
+ (stealth? (whispers-vpn-configuration-stealth? config))
+ (rev-stealth-conf (reverse-stealth-conf config))
+ (rev-stealth-forward (car (ssh-connection-configuration-forwards
+ rev-stealth-conf)))
+ (rev-stealth-port (ssh-forward-configuration-entry-port
+ rev-stealth-forward))
+ (rev-stealth-port-str (number->string rev-stealth-port))
+ (rev-stealth-stance (if stealth?
+ ;; FIXME: not future-proof
+ (string-append "_proxy-port_"
+ rev-stealth-port-str)
+ ""))
+ (tun-stealth-conf (tun-stealth-conf config))
+ (tun-stealth-forward (car (ssh-connection-configuration-forwards
+ tun-stealth-conf)))
+ (tun-stealth-port (ssh-forward-configuration-entry-port
+ tun-stealth-forward))
+ (tun-stealth-port-str (number->string tun-stealth-port))
+ (tun-stealth-stance (if stealth?
+ ;; FIXME: not future-proof
+ (string-append "_proxy-port_"
+ tun-stealth-port-str)
+ "")))
+ (list (shepherd-action
+ (name 'pre-start)
+ (documentation "Stop the 'device-device-forward lieutenant of
+the 'vpn service, then set the 'connected? flag of this client's voucher
+to #f in the server's unpriviledged network state and knock-knock the
+server. The disconnection sequence will complete for this client after
+receiving the server's knock-knock.")
+ (procedure
+ #~(lambda (running)
+ (let* ((server-tun (perform-service-action
+ (lookup-service 'network-rw)
+ 'hostname->tun
+ (gethostname)))
+ (tun-str (number->string server-tun))
+ (stance (string-append #$client-tun-str
+ ":"
+ tun-str))
+ ;; FIXME: not future-proof
+ (name-str (string-append "ssh-forwards_tunnel@"
+ stance
+ #$tun-stealth-stance))
+ (name-sym (string->symbol name-str)))
+ (stop-service (lookup-service name-sym)))
+
+ (start-in-the-background (list '#$handshake-name))
+ (let* ((server-port (perform-service-action (lookup-service
+ 'network-rw)
+ 'hostname->port
+ (gethostname)))
+ (server-port-str (number->string server-port))
+ ;; FIXME: not future-proof
+ (stance (string-append server-port-str
+ ":"
+ "127.0.0.1"
+ ":"
+ #$exit-str))
+ ;; FIXME: not future-proof
+ (name-str (string-append "ssh-forwards_reverse-port@"
+ stance
+ #$rev-stealth-stance))
+ (name-sym (string->symbol name-str)))
+ (stop-service (lookup-service name-sym)))
+ (perform-service-action (lookup-service '#$(tun-dev-sym
+ client-tun))
+ 'stop-tun))))
+ (shepherd-action
+ (name 'start-disconnecting)
+ (documentation "Start the 'disconnecting service")
+ (procedure
+ #~(lambda (running)
+ (start-service (lookup-service 'disconnecting))))))))
+
+(define (whispers-vpn-tree config)
+ "Returns a whispers service tree for a whispers VPN sub-tree,
+configurable by CONFIG, a record of the <whispers-vpn-configuration>
+type."
+ (let ((client? (whispers-vpn-configuration-client? config)))
+ (list (service whispers-service-type
+ (whispers-configuration
+ (name 'vpn)
+ (lieutenants (vpn-lieutenants config))
+ (pre-start-action? client?)
+ (post-stop-action? client?)
+ (extra-actions (vpn-actions config)))))))
+
+(define whispers-vpn-service-type
+ (service-type
+ (name '(whispers-vpn))
+ (description "ssh-tttt!!!")
+ (extensions (list (service-extension whispers-service-type
+ whispers-vpn-tree)))
+ (default-value (whispers-vpn-configuration))))
diff --git a/whispers/services/whispers/xdg.scm b/whispers/services/whispers/xdg.scm
new file mode 100644
index 0000000..acb0b92
--- /dev/null
+++ b/whispers/services/whispers/xdg.scm
@@ -0,0 +1,81 @@
+;;; Whispers --- Stealth VPN and ssh tunneler
+;;; Copyright © 2023 Runciter <runciter@whispers-vpn.org>
+;;;
+;;; This file is part of Whispers.
+;;;
+;;; Whispers 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.
+;;;
+;;; Whispers 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 Whispers. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (whispers services whispers xdg)
+ #:use-module (guix gexp)
+ #:use-module (guix records)
+ #:use-module (gnu system shadow)
+ #:use-module (gnu services)
+ #:use-module (gnu services shepherd)
+ #:use-module (whispers services whispers)
+ #:use-module (gnu packages guile)
+ #:use-module (gnu packages linux)
+ #:export (whispers-xdg-service-type
+ whispers-xdg-configuration
+ whispers-xdg-configuration?
+ xdg-user-group
+ xdg-user-group?))
+
+(define-record-type* <whispers-xdg-configuration>
+ whispers-xdg-configuration make-bitcoin-configuration
+ whispers-xdg-configuration?
+ this-whispers-xdg-configuration
+ ;; A list of xdg-user-group records
+ (users-groups whispers-xdg-configuration-users-groups
+ (default '())))
+
+(define-record-type* <xdg-user-group>
+ xdg-user-group make-xdg-user-group
+ xdg-user-group?
+ this-xdg-user-group
+ ;; A whispers-user-group record
+ (user-and-group xdg-user-group-user-and-group
+ (default (whispers-user-group))))
+
+(define (runtimes-lieutenant user group)
+ "Returns an elementary whispers service tree for a single user's
+section of whispers xdg sub-tree, run by the user named by the string
+USER and the group named by the string GROUP."
+ (service whispers-service-type
+ (whispers-configuration (name (string->symbol
+ (user-container-name user)))
+ (user user)
+ (group group))))
+
+(define (whispers-xdg-tree config)
+ "Returns a whispers service tree for an xdg whispers sub-tree,
+configurable by CONFIG, a record of the <whispers-xdg-configuration> type."
+ (let* ((ugs (whispers-xdg-configuration-users-groups config))
+ (user-group xdg-user-group-user-and-group)
+ (user (lambda (ug) (whispers-user-group-user (user-group ug))))
+ (group (lambda (ug) (whispers-user-group-group (user-group ug)))))
+ (list (service whispers-service-type
+ (whispers-configuration
+ (name 'xdg)
+ (lieutenants (map (lambda (ug)
+ (runtimes-lieutenant (user ug)
+ (group ug)))
+ ugs)))))))
+
+(define whispers-xdg-service-type
+ (service-type
+ (name '(whispers-xdg))
+ (description "Daemonized per-user xdg tmpfs runtime directory.")
+ (extensions (list (service-extension whispers-service-type
+ whispers-xdg-tree)))
+ (default-value (whispers-xdg-configuration))))
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))))
generated by cgit v1.2.3 (git 2.46.2) at 2024-11-01 11:27:48 +0000