GNU bug report logs - #49255
[PATCH 2/4] gnu: Add wondershaper service.

Previous Next

Full log

View this message in rfc822 format

From: Aljosha Papsch <ep <at> stern-data.com>
To: 49255 <at> debbugs.gnu.org
Cc: Aljosha Papsch <ep <at> stern-data.com>
Subject: [bug#49255] [PATCH 2/4] gnu: Add wondershaper service.
Date: Mon, 28 Jun 2021 17:22:30 +0200

* 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.")))
 
+
+;;;
+;;; 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

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.