[bug#49258] [PATCH] Add wondershaper package and service

[bug#49258] [PATCH] Add wondershaper package and service

[Aljosha Papsch]

Hello Guix! 

These patches add a package and service for Wonder Shaper, a nice 
little tool configuring traffic control. The defaults should suffice 
for desktop usage, with the exception of download-speed and upload-speed, 
which must be chosen according to your actual speeds. 

I forked the upstream repository and the package uses the fork. It's not 
meant as a long lived fork. Currently the tool doesn't provide a way 
to specify the config file, users are expected to edit the script. A patch 
is pending upstream (https://github.com/magnific0/wondershaper/pull/68) 
to add a CLI option but in the meantime wondershaper-service would have 
to jump through some hoops to specify the options. 

While at it, I also added two other options for the maximum rate and burst 
rate for the lowest priority traffic class. My goal is to make data 
exfiltration harder in a server environment and a custom rate seems just 
right for that. I plan to send these options upstream as well. If you don't
like exposing non-upstream options, an alternative could be to instead  
expose a list of pairs for arbitrary additional options which get pasted 
into the configuration file. 

Best regards 
Aljosha

[bug#49254] [PATCH 1/4] gnu: Add wondershaper.

[Aljosha Papsch]

* gnu/packages/networking.scm (wondershaper): New variable.
---
 gnu/packages/networking.scm | 45 +++++++++++++++++++++++++++++++++++++
 1 file changed, 45 insertions(+)

diff --git a/gnu/packages/networking.scm b/gnu/packages/networking.scm
index 82c7a0161a..7374ad5dbc 100644
--- a/gnu/packages/networking.scm
+++ b/gnu/packages/networking.scm
@@ -65,6 +65,7 @@
   #:use-module (guix download)
   #:use-module (guix git-download)
   #:use-module (guix build-system cmake)
+  #:use-module (guix build-system copy)
   #:use-module (guix build-system glib-or-gtk)
   #:use-module (guix build-system gnu)
   #:use-module (guix build-system go)
@@ -4196,3 +4197,47 @@ IPv6 Internet connectivity - it also works over IPv4.")
      ;; version. This exception does not (and cannot) modify any license terms
      ;; which apply to the Application, with which you must still comply
      license:lgpl3)))
+
+(define-public wondershaper
+  (package
+    (name "wondershaper")
+    (version "1.4.1")
+    (source
+     (origin
+       (method git-fetch)
+       (uri
+        (git-reference
+         (url "https://github.com/apapsch/wondershaper")
+         (commit "0987dbb0c360184b8aacf391646e19ea9ee78b10")))
+       (file-name (git-file-name name version))
+       (sha256
+        (base32 "1hyivkpvr5pv8wg64i7vgpxib4allbp4v1ahp3qhc1d88rkw7gjs"))))
+    (build-system copy-build-system)
+    (arguments
+     `(#:install-plan '(("./wondershaper" "./bin/"))
+       #:phases
+       (modify-phases %standard-phases
+         (add-after 'patch-shebangs 'patch-invoked-commands
+           (lambda* (#:key outputs inputs #:allow-other-keys)
+             (let* ((out          (assoc-ref outputs "out"))
+                    (bin          (string-append out "/bin")))
+               (substitute* (string-append bin "/wondershaper")
+                 (("^\\s*ip ")
+                  (string-append (which "ip") " "))
+                 (("^\\s*modprobe ")
+                  (string-append (which "modprobe") " "))
+                 (("^\\s*tc ")
+                  (string-append (which "tc") " "))))
+             #t)))))
+    (inputs
+     `(("iproute2" ,iproute)
+       ("kmod"     ,kmod)))
+    (synopsis "Command-line utility for limiting an adapter's bandwidth")
+    (description "Wonder Shaper allows the user to limit the bandwidth of one
+or more network adapters.  It does so by using iproute's tc command, but
+greatly simplifies its operation.  Wonder Shaper was first released by Bert
+Hubert in 2002.  A subsequent release added a command-line interface.  Wonder
+Shaper makes use of tc's Hierarchical Token Bucket (HTB) queue, ensuring good
+bandwidth management on high speed (above ten megabits) links.")
+    (home-page "https://github.com/magnific0/wondershaper")
+    (license license:gpl2)))
-- 
2.32.0

[bug#49254] [PATCH 1/4] gnu: Add wondershaper.

[Maxime Devos]

[-- Attachment #1: Type: text/plain, Size: 1947 bytes --]

Aljosha Papsch schreef op ma 28-06-2021 om 17:22 [+0200]:
> +        (git-reference
> +         (url "https://github.com/apapsch/wondershaper")
> +         (commit "0987dbb0c360184b8aacf391646e19ea9ee78b10")))

Best add a comment like

  ;; Use a fork that allows overriding the configuration file

‘We’ usually try to use upstream versions.

> +       (file-name (git-file-name name version))
> +       (sha256
> +        (base32 "1hyivkpvr5pv8wg64i7vgpxib4allbp4v1ahp3qhc1d88rkw7gjs"))))
> +    (build-system copy-build-system)
> +    (arguments
> +     `(#:install-plan '(("./wondershaper" "./bin/"))
> +       #:phases
> +       (modify-phases %standard-phases
> +         (add-after 'patch-shebangs 'patch-invoked-commands
> +           (lambda* (#:key outputs inputs #:allow-other-keys)
> +             (let* ((out          (assoc-ref outputs "out"))
> +                    (bin          (string-append out "/bin")))
> +               (substitute* (string-append bin "/wondershaper")
> +                 (("^\\s*ip ")
> +                  (string-append (which "ip") " "))

Using (which "blabla") is not correct when cross-compiling, as
"which" looks in $PATH, but "iproute2" (and "kmod") won't be
in $PATH when cross-compiling as they are 'inputs', not 'native-inputs'

You'd need (search-input-file inputs "/bin/ip")
(or maybe "/sbin/ip", I dunno). Actually, search-input-file is
in core-updates, but not yet on 'master', so instead do

  (string-append (assoc-ref inputs "iproute2") "/bin/ip")

or something like that.

Looking at the source code, I see

usage(){
cat  << EOF

so it seems you need to substitute "cat" as well (it is from coreutils).

I'd recommend copying "wondershaper.conf" somewhere
as well, and substituting "/etc/conf.d/wondershaper.conf" and "/etc/systemd/wondershaper.conf"
in 'wondershaper' appropriately, so it will have some defaults.

Greetings,
Maxime.

[-- Attachment #2: This is a digitally signed message part --]
[-- Type: application/pgp-signature, Size: 260 bytes --]

[bug#49255] [PATCH 2/4] gnu: Add wondershaper service.

[Aljosha Papsch]

* gnu/services/networking.scm (wondershaper-configuration): New symbol.
  Configuration for wondershaper-service-type.
* gnu/services/networking.scm (wondershaper-configuration?): New symbol.
  Predicate for wondershaper-configuration.
* gnu/services/networking.scm (wondershaper-service-type): New symbol.
  One-shot service running wondershaper with a generated config file.
---
 gnu/services/networking.scm | 107 +++++++++++++++++++++++++++++++++++-
 1 file changed, 106 insertions(+), 1 deletion(-)

diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm
index 87b3d754a3..a17f41aa30 100644
--- a/gnu/services/networking.scm
+++ b/gnu/services/networking.scm
@@ -221,7 +221,11 @@
 
             keepalived-configuration
             keepalived-configuration?
-            keepalived-service-type))
+            keepalived-service-type
+
+            wondershaper-configuration
+            wondershaper-configuration?
+            wondershaper-service-type))
 
 ;;; Commentary:
 ;;;
@@ -2190,4 +2194,105 @@ of the IPFS peer-to-peer storage network.")))
                  "Run @uref{https://www.keepalived.org/, Keepalived}
 routing software.")))
 
+\f
+;;;
+;;; Wondershaper
+;;;
+
+(define %wondershaper-default-download-speed 2048)
+
+(define-record-type* <wondershaper-configuration>
+  wondershaper-configuration make-wondershaper-configuration
+  wondershaper-configuration?
+  (wondershaper      wondershaper-configuration-wondershaper ;<package>
+                     (default wondershaper))
+  (interface         wondershaper-configuration-interface         ;string
+                     (default "eth0"))
+  (download-speed    wondershaper-configuration-download-speed    ;number (kbps)
+                     (default %wondershaper-default-download-speed))
+  (upload-speed      wondershaper-configuration-upload-speed      ;number (kbps)
+                     (default 512))
+  (prio-3-rate       wondershaper-configuration-prio-3-rate       ;number (kbps)
+                     (default (/ (* 20 %wondershaper-default-download-speed) 100)))
+  (prio-3-ceil       wondershaper-configuration-prio-3-ceil
+                     (default (/ (* 90 %wondershaper-default-download-speed) 100)))
+  (high-prio-dest    wondershaper-configuration-high-prio-dest    ;list of ip addresses
+                     (default '()))
+  (no-prio-host-src  wondershaper-configuration-no-prio-host-src  ;list of ip addresses
+                     (default '()))
+  (no-prio-host-dest wondershaper-configuration-no-prio-host-dest ;list of ip addresses
+                     (default '()))
+  (no-prio-port-src  wondershaper-configuration-no-prio-port-src  ;list of port numbers
+                     (default '()))
+  (no-prio-port-dest wondershaper-configuration-no-prio-port-dest ;list of port numbers
+                     (default '())))
+
+(define wondershaper-config-file
+  (match-lambda
+    (($ <wondershaper-configuration> _ interface download-speed
+                                     upload-speed prio-3-rate prio-3-ceil high-prio-dest
+                                     no-prio-host-src no-prio-host-dest
+                                     no-prio-port-src no-prio-port-dest)
+     (begin
+       (define (shell-quote str)
+         "Return STR wrapped in single quotes, with every single quote in the string escaped."
+         (let ((quote-char (lambda (chr)
+                             (if (eq? chr #\')
+                                 "'\\''"
+                                 (string chr)))))
+           (string-append
+            "'"
+            (let loop ((chars  (string->list str))
+                       (result ""))
+              (match chars
+                (() result)
+                ((head tail ...)
+                 (loop tail
+                       (string-append result
+                                      (quote-char head))))))
+            "'")))
+       (define (list->bash-array lst)
+         (string-append "(" (string-join (map shell-quote lst)) ")"))
+       (define (format-config)
+         (string-append
+          "IFACE=" (shell-quote interface) "
+DSPEED=\"" (number->string download-speed) "\"
+USPEED=\"" (number->string upload-speed) "\"
+PRIO_3_RATE=\"" (number->string prio-3-rate) "\"
+PRIO_3_CEIL=\"" (number->string prio-3-ceil) "\"
+HIPRIODST=" (list->bash-array high-prio-dest) "
+NOPRIOHOSTSRC=" (list->bash-array no-prio-host-src) "
+NOPRIOHOSTDST=" (list->bash-array no-prio-host-dest) "
+NOPRIOPORTSRC=" (list->bash-array (map number->string no-prio-port-src)) "
+NOPRIOPORTDST=" (list->bash-array (map number->string no-prio-port-dest)) "
+"))
+       (computed-file
+        "wondershaper.conf"
+        #~(call-with-output-file #$output
+            (lambda (port)
+              (display "# Generated by wondershaper-service\n" port)
+              (display #$(format-config) port))))))))
+
+(define (wondershaper-shepherd-service config)
+  (match config
+    (($ <wondershaper-configuration> wondershaper)
+     (list (shepherd-service
+            (provision '(wondershaper))
+            (documentation "Configure traffic control")
+            (requirement '(networking))
+            (start #~(lambda _
+                       (invoke #$(file-append wondershaper "/bin/wondershaper")
+                               "-p" "-f" #$(wondershaper-config-file config))))
+            (one-shot? #t))))))
+
+(define wondershaper-service-type
+  (service-type
+   (name 'wondershaper)
+   (extensions
+    (list (service-extension shepherd-root-service-type
+                             wondershaper-shepherd-service)))
+   (default-value (wondershaper-configuration))
+   (description "Run @uref{https://github.com/magnific0/wondershaper,
+wondershaper}, a small utility script setting up traffic control (tc).")))
+
 ;;; networking.scm ends here
-- 
2.32.0

[bug#49256] [PATCH 3/4] guix.texi: Document wondershaper-service-type.

[Aljosha Papsch]

* doc/guix.texi: Document wondershaper-service-type and
  wondershaper-configuration fields.
---
 doc/guix.texi | 73 +++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 73 insertions(+)

diff --git a/doc/guix.texi b/doc/guix.texi
index e71ec70859..14764bfae4 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -16890,6 +16890,79 @@ See @uref{https://www.torproject.org/docs/tor-hidden-service.html.en, the Tor
 project's documentation} for more information.
 @end deffn
 
+@cindex Wondershaper
+@defvr {Scheme Variable} wondershaper-service-type
+This is the type for a service that runs
+@uref{https://github.com/magnific0/wondershaper, Wonder Shaper} once
+during boot.  It configures traffic control (tc) with a Hierarchy Token
+Bucket (htb) queue both for upload and download.  For upload three
+classes are added in order to prioritize traffic. Priority 1 is the
+highest priority and priority 3 is the lowest priority.  Interactive
+traffic (e.g. ssh) is designated priority 1, while non-interactive
+traffic is designated priority 2.  Priority 3 is reserved for specially
+configured ports and addresses.  The service is configured using a
+@code{<wondershaper-configuration>} record.  Some options below are not
+found in the original upstream release but are maintained
+@uref{https://github.com/apapsch/wondershaper, in a fork} until merged.
+These options are marked specially.
+
+@end defvr
+
+@deftp {Data Type} wondershaper-configuration
+@table @asis
+@item @code{wondershaper} (default: @code{wondershaper})
+The package that provides Wonder Shaper.  This package is expected to
+provide the script at @file{bin/wondershaper} relative to its output
+directory.  The default package is
+@uref{https://github.com/apapsch/wondershaper, a fork of Wonder Shaper}
+adding more configuration options.
+
+@item @code{interface} (default: @code{"eth0"})
+The interface for which the limits shall be applied.
+
+@item @code{download-speed} (default: @code{2048})
+Maximum download speed in kbits. Tune this parameter to be a bit less than
+your actual download speed.
+
+@item @code{upload-speed} (default: @code{512})
+Maximum upload speed in kbits. Tune this parameter to be a bit less than
+your actual upload speed.
+
+@item @code{prio-3-rate} (default: @code{download-speed * 20 / 100})
+Maximum rate (kbits) for the priority 3 class, which is the lowest priority for
+upload traffic.  In a desktop environment the default computed value
+should suffice, while in a controlled environment you might want to set
+a static value.  This option exists only in the fork!
+
+@item @code{prio-3-ceil} (default: @code{download-speed * 90 / 100})
+Maximum burst rate (kbits) for the priority 3 class.  The same remarks as
+for @code{prio-3-rate} apply. This option exists only in the fork!
+
+@item @code{high-prio-dest} (default: @code{'()})
+List of destination IP addresses for which traffic is designated
+priority 1.  This applies to upload only.  Note that SSH (not SCP), ICMP
+and packets smaller than 64b are automatically designated priority 1 no
+matter the destination address.
+
+@item @code{no-prio-host-src} (default: @code{'()})
+List of source IP addresses for which traffic is designated priority 3.
+This applies to upload only.
+
+@item @code{no-prio-host-dest} (default: @code{'()})
+List of destination IP addresses for which traffic is designated
+priority 3.  This applies to upload only.
+
+@item @code{no-prio-port-src} (default: @code{'()})
+List of source port numbers for which traffic is designated priority 3.
+This applies to upload only.
+
+@item @code{no-prio-port-dest} (default: @code{'()})
+List of destination port numbers for which traffic is designated
+priority 3.  This applies to upload only.
+
+@end table
+@end deftp
+
 The @code{(gnu services rsync)} module provides the following services:
 
 You might want an rsync daemon if you have files that you want available
-- 
2.32.0

[bug#49257] [PATCH 4/4] Add wondershaper related copright lines.

[Aljosha Papsch]

---
 doc/guix.texi               | 1 +
 gnu/packages/networking.scm | 1 +
 gnu/services/networking.scm | 1 +
 3 files changed, 3 insertions(+)

diff --git a/doc/guix.texi b/doc/guix.texi
index 14764bfae4..2c86b00d49 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -90,6 +90,7 @@ Copyright @copyright{} 2020 Edgar Vincent@*
 Copyright @copyright{} 2021 Maxime Devos@*
 Copyright @copyright{} 2021 B. Wilson@*
 Copyright @copyright{} 2021 Xinglu Chen@*
+Copyright @copyright{} 2021 Aljosha Papsch@*
 
 Permission is granted to copy, distribute and/or modify this document
 under the terms of the GNU Free Documentation License, Version 1.3 or
diff --git a/gnu/packages/networking.scm b/gnu/packages/networking.scm
index 7374ad5dbc..878907f61f 100644
--- a/gnu/packages/networking.scm
+++ b/gnu/packages/networking.scm
@@ -43,6 +43,7 @@
 ;;; Copyright © 2020 Hamzeh Nasajpour <h.nasajpour@pantherx.org>
 ;;; Copyright © 2020 Michael Rohleder <mike@rohleder.de>
 ;;; Copyright © 2021 Hartmut Goebel <h.goebel@crazy-compilers.com>
+;;; Copyright © 2021 Aljosha Papsch <ep@stern-data.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm
index a17f41aa30..c48cf50452 100644
--- a/gnu/services/networking.scm
+++ b/gnu/services/networking.scm
@@ -17,6 +17,7 @@
 ;;; Copyright © 2021 Oleg Pykhalov <go.wigust@gmail.com>
 ;;; Copyright © 2021 Christopher Lemmer Webber <cwebber@dustycloud.org>
 ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
+;;; Copyright © 2021 Aljosha Papsch <ep@stern-data.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
-- 
2.32.0

[bug#49258] [PATCH v2] Revise wondershaper package

[Aljosha Papsch]

Hello, 

this new patch version takes care of the points raised by Maxime
(https://issues.guix.gnu.org/49254#2):

* add a comment describing why a fork is used 
* replace (which ...) with (string-append (assoc-ref inputs ...) ...). 
* copy config file to store and substitute store file as fallback config. 
* substitute "cat" with full name from coreutils package.

Please take another look at these patches.

Thanks

[bug#49258] [PATCH 1/4] gnu: Add wondershaper.

[Aljosha Papsch]

* gnu/packages/networking.scm (wondershaper): New variable.
---
 gnu/packages/networking.scm | 51 +++++++++++++++++++++++++++++++++++++
 1 file changed, 51 insertions(+)

diff --git a/gnu/packages/networking.scm b/gnu/packages/networking.scm
index fe73c9cdc7..920d01d8e5 100644
--- a/gnu/packages/networking.scm
+++ b/gnu/packages/networking.scm
@@ -64,6 +64,7 @@
   #:use-module (guix download)
   #:use-module (guix git-download)
   #:use-module (guix build-system cmake)
+  #:use-module (guix build-system copy)
   #:use-module (guix build-system glib-or-gtk)
   #:use-module (guix build-system gnu)
   #:use-module (guix build-system go)
@@ -4069,3 +4070,53 @@ IPv6 Internet connectivity - it also works over IPv4.")
      ;; version. This exception does not (and cannot) modify any license terms
      ;; which apply to the Application, with which you must still comply
      license:lgpl3)))
+
+(define-public wondershaper
+  (package
+    (name "wondershaper")
+    (version "1.4.1")
+    (source
+     (origin
+       (method git-fetch)
+       (uri
+        ;; Use a fork that allows overriding the configuration file
+        (git-reference
+         (url "https://github.com/apapsch/wondershaper")
+         (commit "0987dbb0c360184b8aacf391646e19ea9ee78b10")))
+       (file-name (git-file-name name version))
+       (sha256
+        (base32 "1hyivkpvr5pv8wg64i7vgpxib4allbp4v1ahp3qhc1d88rkw7gjs"))))
+    (build-system copy-build-system)
+    (arguments
+     `(#:install-plan '(("./wondershaper" "./bin/")
+                        ("./wondershaper.conf" "./etc/"))
+       #:phases
+       (modify-phases %standard-phases
+         (add-after 'patch-shebangs 'patch-invoked-commands
+           (lambda* (#:key outputs inputs #:allow-other-keys)
+             (let* ((out (assoc-ref outputs "out")))
+               (substitute* (string-append out "/bin/wondershaper")
+                 (("^\\s*ip ")
+                  (string-append (assoc-ref inputs "iproute2") "/sbin/ip "))
+                 (("^\\s*modprobe ")
+                  (string-append (assoc-ref inputs "kmod") "/bin/modprobe "))
+                 (("^\\s*tc ")
+                  (string-append (assoc-ref inputs "iproute2") "/sbin/tc "))
+                 (("^\\s*cat ")
+                  (string-append (assoc-ref inputs "coreutils") "/bin/cat "))
+                 (("/etc/.+/wondershaper.conf")
+                  (string-append out "/etc/wondershaper.conf"))))
+             #t)))))
+    (inputs
+     `(("coreutils" ,coreutils)
+       ("iproute2"  ,iproute)
+       ("kmod"      ,kmod)))
+    (synopsis "Command-line utility for limiting an adapter's bandwidth")
+    (description "Wonder Shaper allows the user to limit the bandwidth of one
+or more network adapters.  It does so by using iproute's tc command, but
+greatly simplifies its operation.  Wonder Shaper was first released by Bert
+Hubert in 2002.  A subsequent release added a command-line interface.  Wonder
+Shaper makes use of tc's Hierarchical Token Bucket (HTB) queue, ensuring good
+bandwidth management on high speed (above ten megabits) links.")
+    (home-page "https://github.com/magnific0/wondershaper")
+    (license license:gpl2)))
-- 
2.32.0

[bug#49258] [PATCH 2/4] gnu: Add wondershaper service.

[Aljosha Papsch]

* gnu/services/networking.scm (wondershaper-configuration): New symbol.
  Configuration for wondershaper-service-type.
* gnu/services/networking.scm (wondershaper-configuration?): New symbol.
  Predicate for wondershaper-configuration.
* gnu/services/networking.scm (wondershaper-service-type): New symbol.
  One-shot service running wondershaper with a generated config file.
---
 gnu/services/networking.scm | 107 +++++++++++++++++++++++++++++++++++-
 1 file changed, 106 insertions(+), 1 deletion(-)

diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm
index 1ae58041d3..1d3e061758 100644
--- a/gnu/services/networking.scm
+++ b/gnu/services/networking.scm
@@ -218,7 +218,11 @@
 
             keepalived-configuration
             keepalived-configuration?
-            keepalived-service-type))
+            keepalived-service-type
+
+            wondershaper-configuration
+            wondershaper-configuration?
+            wondershaper-service-type))
 
 ;;; Commentary:
 ;;;
@@ -2151,4 +2155,105 @@ of the IPFS peer-to-peer storage network.")))
                  "Run @uref{https://www.keepalived.org/, Keepalived}
 routing software.")))
 
+\f
+;;;
+;;; Wondershaper
+;;;
+
+(define %wondershaper-default-download-speed 2048)
+
+(define-record-type* <wondershaper-configuration>
+  wondershaper-configuration make-wondershaper-configuration
+  wondershaper-configuration?
+  (wondershaper      wondershaper-configuration-wondershaper ;<package>
+                     (default wondershaper))
+  (interface         wondershaper-configuration-interface         ;string
+                     (default "eth0"))
+  (download-speed    wondershaper-configuration-download-speed    ;number (kbps)
+                     (default %wondershaper-default-download-speed))
+  (upload-speed      wondershaper-configuration-upload-speed      ;number (kbps)
+                     (default 512))
+  (prio-3-rate       wondershaper-configuration-prio-3-rate       ;number (kbps)
+                     (default (/ (* 20 %wondershaper-default-download-speed) 100)))
+  (prio-3-ceil       wondershaper-configuration-prio-3-ceil
+                     (default (/ (* 90 %wondershaper-default-download-speed) 100)))
+  (high-prio-dest    wondershaper-configuration-high-prio-dest    ;list of ip addresses
+                     (default '()))
+  (no-prio-host-src  wondershaper-configuration-no-prio-host-src  ;list of ip addresses
+                     (default '()))
+  (no-prio-host-dest wondershaper-configuration-no-prio-host-dest ;list of ip addresses
+                     (default '()))
+  (no-prio-port-src  wondershaper-configuration-no-prio-port-src  ;list of port numbers
+                     (default '()))
+  (no-prio-port-dest wondershaper-configuration-no-prio-port-dest ;list of port numbers
+                     (default '())))
+
+(define wondershaper-config-file
+  (match-lambda
+    (($ <wondershaper-configuration> _ interface download-speed
+                                     upload-speed prio-3-rate prio-3-ceil high-prio-dest
+                                     no-prio-host-src no-prio-host-dest
+                                     no-prio-port-src no-prio-port-dest)
+     (begin
+       (define (shell-quote str)
+         "Return STR wrapped in single quotes, with every single quote in the string escaped."
+         (let ((quote-char (lambda (chr)
+                             (if (eq? chr #\')
+                                 "'\\''"
+                                 (string chr)))))
+           (string-append
+            "'"
+            (let loop ((chars  (string->list str))
+                       (result ""))
+              (match chars
+                (() result)
+                ((head tail ...)
+                 (loop tail
+                       (string-append result
+                                      (quote-char head))))))
+            "'")))
+       (define (list->bash-array lst)
+         (string-append "(" (string-join (map shell-quote lst)) ")"))
+       (define (format-config)
+         (string-append
+          "IFACE=" (shell-quote interface) "
+DSPEED=\"" (number->string download-speed) "\"
+USPEED=\"" (number->string upload-speed) "\"
+PRIO_3_RATE=\"" (number->string prio-3-rate) "\"
+PRIO_3_CEIL=\"" (number->string prio-3-ceil) "\"
+HIPRIODST=" (list->bash-array high-prio-dest) "
+NOPRIOHOSTSRC=" (list->bash-array no-prio-host-src) "
+NOPRIOHOSTDST=" (list->bash-array no-prio-host-dest) "
+NOPRIOPORTSRC=" (list->bash-array (map number->string no-prio-port-src)) "
+NOPRIOPORTDST=" (list->bash-array (map number->string no-prio-port-dest)) "
+"))
+       (computed-file
+        "wondershaper.conf"
+        #~(call-with-output-file #$output
+            (lambda (port)
+              (display "# Generated by wondershaper-service\n" port)
+              (display #$(format-config) port))))))))
+
+(define (wondershaper-shepherd-service config)
+  (match config
+    (($ <wondershaper-configuration> wondershaper)
+     (list (shepherd-service
+            (provision '(wondershaper))
+            (documentation "Configure traffic control")
+            (requirement '(networking))
+            (start #~(lambda _
+                       (invoke #$(file-append wondershaper "/bin/wondershaper")
+                               "-p" "-f" #$(wondershaper-config-file config))))
+            (one-shot? #t))))))
+
+(define wondershaper-service-type
+  (service-type
+   (name 'wondershaper)
+   (extensions
+    (list (service-extension shepherd-root-service-type
+                             wondershaper-shepherd-service)))
+   (default-value (wondershaper-configuration))
+   (description "Run @uref{https://github.com/magnific0/wondershaper,
+wondershaper}, a small utility script setting up traffic control (tc).")))
+
 ;;; networking.scm ends here
-- 
2.32.0

[bug#49258] [PATCH 3/4] guix.texi: Document wondershaper-service-type.

[Aljosha Papsch]

* doc/guix.texi: Document wondershaper-service-type and
  wondershaper-configuration fields.
---
 doc/guix.texi | 73 +++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 73 insertions(+)

diff --git a/doc/guix.texi b/doc/guix.texi
index 18bc600440..58238f5935 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -16945,6 +16945,79 @@ See @uref{https://www.torproject.org/docs/tor-hidden-service.html.en, the Tor
 project's documentation} for more information.
 @end deffn
 
+@cindex Wondershaper
+@defvr {Scheme Variable} wondershaper-service-type
+This is the type for a service that runs
+@uref{https://github.com/magnific0/wondershaper, Wonder Shaper} once
+during boot.  It configures traffic control (tc) with a Hierarchy Token
+Bucket (htb) queue both for upload and download.  For upload three
+classes are added in order to prioritize traffic. Priority 1 is the
+highest priority and priority 3 is the lowest priority.  Interactive
+traffic (e.g. ssh) is designated priority 1, while non-interactive
+traffic is designated priority 2.  Priority 3 is reserved for specially
+configured ports and addresses.  The service is configured using a
+@code{<wondershaper-configuration>} record.  Some options below are not
+found in the original upstream release but are maintained
+@uref{https://github.com/apapsch/wondershaper, in a fork} until merged.
+These options are marked specially.
+
+@end defvr
+
+@deftp {Data Type} wondershaper-configuration
+@table @asis
+@item @code{wondershaper} (default: @code{wondershaper})
+The package that provides Wonder Shaper.  This package is expected to
+provide the script at @file{bin/wondershaper} relative to its output
+directory.  The default package is
+@uref{https://github.com/apapsch/wondershaper, a fork of Wonder Shaper}
+adding more configuration options.
+
+@item @code{interface} (default: @code{"eth0"})
+The interface for which the limits shall be applied.
+
+@item @code{download-speed} (default: @code{2048})
+Maximum download speed in kbits. Tune this parameter to be a bit less than
+your actual download speed.
+
+@item @code{upload-speed} (default: @code{512})
+Maximum upload speed in kbits. Tune this parameter to be a bit less than
+your actual upload speed.
+
+@item @code{prio-3-rate} (default: @code{download-speed * 20 / 100})
+Maximum rate (kbits) for the priority 3 class, which is the lowest priority for
+upload traffic.  In a desktop environment the default computed value
+should suffice, while in a controlled environment you might want to set
+a static value.  This option exists only in the fork!
+
+@item @code{prio-3-ceil} (default: @code{download-speed * 90 / 100})
+Maximum burst rate (kbits) for the priority 3 class.  The same remarks as
+for @code{prio-3-rate} apply. This option exists only in the fork!
+
+@item @code{high-prio-dest} (default: @code{'()})
+List of destination IP addresses for which traffic is designated
+priority 1.  This applies to upload only.  Note that SSH (not SCP), ICMP
+and packets smaller than 64b are automatically designated priority 1 no
+matter the destination address.
+
+@item @code{no-prio-host-src} (default: @code{'()})
+List of source IP addresses for which traffic is designated priority 3.
+This applies to upload only.
+
+@item @code{no-prio-host-dest} (default: @code{'()})
+List of destination IP addresses for which traffic is designated
+priority 3.  This applies to upload only.
+
+@item @code{no-prio-port-src} (default: @code{'()})
+List of source port numbers for which traffic is designated priority 3.
+This applies to upload only.
+
+@item @code{no-prio-port-dest} (default: @code{'()})
+List of destination port numbers for which traffic is designated
+priority 3.  This applies to upload only.
+
+@end table
+@end deftp
+
 The @code{(gnu services rsync)} module provides the following services:
 
 You might want an rsync daemon if you have files that you want available
-- 
2.32.0

[bug#49258] [PATCH 4/4] Add wondershaper related copright lines.

[Aljosha Papsch]

---
 doc/guix.texi               | 8 ++++++--
 gnu/packages/networking.scm | 1 +
 gnu/services/networking.scm | 1 +
 3 files changed, 8 insertions(+), 2 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 58238f5935..b07c7d7ebe 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -91,7 +91,7 @@ Copyright @copyright{} 2020 Edgar Vincent@*
 Copyright @copyright{} 2021 Maxime Devos@*
 Copyright @copyright{} 2021 B. Wilson@*
 Copyright @copyright{} 2021 Xinglu Chen@*
-Copyright @copyright{} 2021 Raghav Gururajan@*
+Copyright @copyright{} 2021 Aljosha Papsch@*
 Copyright @copyright{} 2021 Domagoj Stolfa@*
 Copyright @copyright{} 2021 Hui Lu@*
 
@@ -864,6 +864,7 @@ version 0.1.0 or later;
 @item @uref{https://www.nongnu.org/guile-avahi/, Guile-Avahi};
 @item
 @uref{https://gitlab.com/guile-git/guile-git, Guile-Git}, version 0.5.0
+
 or later;
 @item @uref{https://savannah.nongnu.org/projects/guile-json/, Guile-JSON}
 4.3.0 or later;
@@ -3740,6 +3741,7 @@ other substitute server.
 @cindex ACL (access control list), for substitutes
 To allow Guix to download substitutes from @code{@value{SUBSTITUTE-SERVER-1}}, @code{@value{SUBSTITUTE-SERVER-2}} or a mirror, you
 must add the relevant public key to the access control list (ACL) of archive
+
 imports, using the @command{guix archive} command (@pxref{Invoking guix
 archive}).  Doing so implies that you trust the substitute server to not
 be compromised and to serve genuine substitutes.
@@ -18817,6 +18819,7 @@ Specifies whether to support HTTP keep-alive connections.
 Defaults to @samp{#t}.
 @end deftypevr
 
+
 @deftypevr {@code{cups-configuration} parameter} non-negative-integer limit-request-body
 Specifies the maximum size of print files, IPP requests, and HTML form
 data.  A limit of 0 disables the limit check.
@@ -27233,6 +27236,7 @@ Defaults to @samp{#f}.
 
 @end deftypevr
 
+
 @c %end of automatic openvpn-server documentation
 
 @subheading strongSwan
@@ -35513,4 +35517,4 @@ providing artwork and themes, making suggestions, and more---thank you!
 
 @c Local Variables:
 @c ispell-local-dictionary: "american";
-@c End:
+@c End:
\ No newline at end of file
diff --git a/gnu/packages/networking.scm b/gnu/packages/networking.scm
index 920d01d8e5..4feffcd2c7 100644
--- a/gnu/packages/networking.scm
+++ b/gnu/packages/networking.scm
@@ -42,6 +42,7 @@
 ;;; Copyright © 2020 Hamzeh Nasajpour <h.nasajpour@pantherx.org>
 ;;; Copyright © 2020 Michael Rohleder <mike@rohleder.de>
 ;;; Copyright © 2021 Hartmut Goebel <h.goebel@crazy-compilers.com>
+;;; Copyright © 2021 Aljosha Papsch <ep@stern-data.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm
index 1d3e061758..4fb9c788d4 100644
--- a/gnu/services/networking.scm
+++ b/gnu/services/networking.scm
@@ -17,6 +17,7 @@
 ;;; Copyright © 2021 Oleg Pykhalov <go.wigust@gmail.com>
 ;;; Copyright © 2021 Christopher Lemmer Webber <cwebber@dustycloud.org>
 ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
+;;; Copyright © 2021 Aljosha Papsch <ep@stern-data.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
-- 
2.32.0