Merge branch 'master' into gnome-team gnome-team

4 files changed, 232 insertions, 101 deletions

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 636d827ff9..492cf8a693 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -10,7 +10,7 @@
 ;;; Copyright © 2019 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;; Copyright © 2019 John Soo <jsoo1@asu.edu>
-;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2019, 2023 Janneke Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
 ;;; Copyright © 2020, 2021 Brice Waegeneire <brice@waegenei.re>
 ;;; Copyright © 2021 qblade <qblade@protonmail.com>
@@ -2726,7 +2726,7 @@ to CONFIG."
   (match (static-networking-addresses config)
     ((and addresses (first _ ...))
      `("--ipv6" "/servers/socket/26"
-       "--interface" ,(network-address-device first)
+       "--interface" ,(string-append "/dev/" (network-address-device first))
        ,@(append-map (lambda (address)
                        `(,(if (network-address-ipv6? address)
                               "--address6"
@@ -2769,7 +2769,10 @@ to CONFIG."
                            (format #t "starting '~a~{ ~s~}'~%"
                                    #$(file-append hurd "/hurd/pfinet")
                                    options)
-                           (apply invoke #$(file-append hurd "/bin/settrans") "-fac"
+                           (apply invoke #$(file-append hurd "/bin/settrans")
+                                  "--active"
+                                  "--create"
+                                  "--keep-active"
                                   "/servers/socket/2"
                                   #$(file-append hurd "/hurd/pfinet")
                                   options)))))))
diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm
index c24a403935..4b47acf72a 100644
--- a/gnu/services/herd.scm
+++ b/gnu/services/herd.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016-2019, 2022-2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -51,6 +52,7 @@
             live-service-canonical-name
 
             with-shepherd-action
+            current-service
             current-services
             unload-services
             unload-service
@@ -208,31 +210,43 @@ of pairs."
   "Return the 'canonical name' of SERVICE."
   (first (live-service-provision service)))
 
-(define (current-services)
-  "Return the list of currently defined Shepherd services, represented as
-<live-service> objects.  Return #f if the list of services could not be
-obtained."
-  (with-shepherd-action 'root ('status) results
-    ;; We get a list of results, one for each service with the name 'root'.
+(define (current-service name)
+  "Return the currently defined Shepherd service NAME, as a <live-service>
+object.  Return #f if the service could not be obtained.  As a special case,
+@code{(current-service 'root)} returns all the current services."
+  (define (process-services services)
+    (resolve-transients
+     (map (lambda (service)
+            (alist-let* service (provides requires running transient?)
+              ;; The Shepherd 0.9.0 would not provide 'transient?' in
+              ;; its status sexp.  Thus, when it's missing, query it
+              ;; via an "eval" request.
+              (live-service provides requires
+                            (if (sloppy-assq 'transient? service)
+                                transient?
+                                (and running *unspecified*))
+                            running)))
+          services)))
+
+  (with-shepherd-action name ('status) results
+    ;; We get a list of results, one for each service with the name NAME.
     ;; In practice there's only one such service though.
     (match results
       ((services _ ...)
        (match services
          ((('service ('version 0 _ ...) _ ...) ...)
-          (resolve-transients
-           (map (lambda (service)
-                  (alist-let* service (provides requires running transient?)
-                    ;; The Shepherd 0.9.0 would not provide 'transient?' in its
-                    ;; status sexp.  Thus, when it's missing, query it via an
-                    ;; "eval" request.
-                    (live-service provides requires
-                                  (if (sloppy-assq 'transient? service)
-                                      transient?
-                                      (and running *unspecified*))
-                                  running)))
-                services)))
+          ;; Summary of all services (when NAME is 'root or 'shepherd).
+          (process-services services))
+         (('service ('version 0 _ ...) _ ...) ;single service
+          (first (process-services (list services))))
          (x
-          #f))))))
+          #f))))))                ;singleton
+
+(define (current-services)
+  "Return the list of currently defined Shepherd services, represented as
+<live-service> objects.  Return #f if the list of services could not be
+obtained."
+  (current-service 'root))
 
 (define (resolve-transients services)
   "Resolve the subset of SERVICES whose 'transient?' field is undefined.  This
diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm
index 506f5a7ab6..eef7ffd1c7 100644
--- a/gnu/services/virtualization.scm
+++ b/gnu/services/virtualization.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 Ryan Moe <ryan.moe@gmail.com>
 ;;; Copyright © 2018, 2020-2023 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2020,2021 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2020, 2021, 2023 Janneke Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2021 Timotej Lazar <timotej.lazar@araneo.si>
 ;;; Copyright © 2022 Oleg Pykhalov <go.wigust@gmail.com>
 ;;; Copyright © 2022 Leo Nikkilä <hello@lnikki.la>
@@ -1106,7 +1106,7 @@ that will be listening to receive secret keys on port 1004, TCP."
   (disk-size   hurd-vm-configuration-disk-size          ;number or 'guess
                (default 'guess))
   (memory-size hurd-vm-configuration-memory-size        ;number
-               (default 512))
+               (default 2048))
   (options     hurd-vm-configuration-options            ;list of string
                (default `("--snapshot")))
   (id          hurd-vm-configuration-id                 ;#f or integer [1..]
diff --git a/gnu/services/vpn.scm b/gnu/services/vpn.scm
index a884d71eb2..9c8243d131 100644
--- a/gnu/services/vpn.scm
+++ b/gnu/services/vpn.scm
@@ -11,6 +11,7 @@
 ;;; Copyright © 2021 Nathan Dehnel <ncdehnel@gmail.com>
 ;;; Copyright © 2022 Cameron V Chaparro <cameron@cameronchaparro.com>
 ;;; Copyright © 2022 Timo Wilken <guix@twilken.net>
+;;; Copyright © 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -31,16 +32,19 @@
   #:use-module (gnu services)
   #:use-module (gnu services configuration)
   #:use-module (gnu services dbus)
+  #:use-module (gnu services mcron)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system shadow)
   #:use-module (gnu packages admin)
   #:use-module (gnu packages vpn)
+  #:use-module (guix modules)
   #:use-module (guix packages)
   #:use-module (guix records)
   #:use-module (guix gexp)
   #:use-module (guix i18n)
   #:use-module (guix deprecation)
   #:use-module (srfi srfi-1)
+  #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:export (openvpn-client-service  ; deprecated
@@ -73,6 +77,8 @@
             wireguard-configuration-addresses
             wireguard-configuration-port
             wireguard-configuration-dns
+            wireguard-configuration-monitor-ips?
+            wireguard-configuration-monitor-ips-interval
             wireguard-configuration-private-key
             wireguard-configuration-peers
             wireguard-configuration-pre-up
@@ -740,7 +746,11 @@ strongSwan.")))
   (peers              wireguard-configuration-peers ;list of <wiregard-peer>
                       (default '()))
   (dns                wireguard-configuration-dns ;list of strings
+                      (default '()))
+  (monitor-ips?       wireguard-configuration-monitor-ips? ;boolean
                       (default #f))
+  (monitor-ips-interval wireguard-configuration-monitor-ips-interval
+                        (default '(next-minute (range 0 60 5)))) ;string | list
   (pre-up             wireguard-configuration-pre-up ;list of strings
                       (default '()))
   (post-up            wireguard-configuration-post-up ;list of strings
@@ -754,24 +764,15 @@ strongSwan.")))
 
 (define (wireguard-configuration-file config)
   (define (peer->config peer)
-    (let ((name (wireguard-peer-name peer))
-          (public-key (wireguard-peer-public-key peer))
-          (endpoint (wireguard-peer-endpoint peer))
-          (allowed-ips (wireguard-peer-allowed-ips peer))
-          (keep-alive (wireguard-peer-keep-alive peer)))
-      (format #f "[Peer] #~a
-PublicKey = ~a
-AllowedIPs = ~a
-~a~a"
-              name
-              public-key
-              (string-join allowed-ips ",")
-              (if endpoint
-                  (format #f "Endpoint = ~a\n" endpoint)
-                  "")
-              (if keep-alive
-                  (format #f "PersistentKeepalive = ~a\n" keep-alive)
-                  "\n"))))
+    (match-record peer <wireguard-peer>
+      (name public-key endpoint allowed-ips keep-alive)
+      (let ((lines (list
+                    (format #f "[Peer]   #~a" name)
+                    (format #f "PublicKey = ~a" public-key)
+                    (format #f "AllowedIPs = ~{~a~^, ~}" allowed-ips)
+                    (format #f "~@[Endpoint = ~a~]" endpoint)
+                    (format #f "~@[PersistentKeepalive = ~a~]" keep-alive))))
+        (string-join (remove string-null? lines) "\n"))))
 
   (define (peers->preshared-keys peer keys)
     (let ((public-key (wireguard-peer-public-key peer))
@@ -790,65 +791,44 @@ AllowedIPs = ~a
             (computed-file
              "wireguard-config"
              #~(begin
+                 (use-modules (ice-9 format)
+                              (srfi srfi-1))
+
+                 (define lines
+                   (list
+                    "[Interface]"
+                    #$@(if (null? addresses)
+                           '()
+                           (list (format #f "Address = ~{~a~^, ~}"
+                                         addresses)))
+                    (format #f "~@[Table = ~a~]" #$table)
+                    #$@(if (null? pre-up)
+                           '()
+                           (list (format #f "~{PreUp = ~a~%~}" pre-up)))
+                    (format #f "PostUp = ~a set %i private-key ~a\
+~{ peer ~a preshared-key ~a~}" #$(file-append wireguard "/bin/wg")
+#$private-key '#$peer-keys)
+                    #$@(if (null? post-up)
+                           '()
+                           (list (format #f "~{PostUp = ~a~%~}" post-up)))
+                    #$@(if (null? pre-down)
+                           '()
+                           (list (format #f "~{PreDown = ~a~%~}" pre-down)))
+                    #$@(if (null? post-down)
+                           '()
+                           (list (format #f "~{PostDown = ~a~%~}" post-down)))
+                    (format #f "~@[ListenPort = ~a~]" #$port)
+                    #$@(if (null? dns)
+                           '()
+                           (list (format #f "~{DNS = ~{~a~^, ~}" dns)))))
+
                  (mkdir #$output)
                  (chdir #$output)
                  (call-with-output-file #$config-file
                    (lambda (port)
-                     (let ((format (@ (ice-9 format) format)))
-                       (format port "[Interface]
-Address = ~a
-~a
-~a
-PostUp = ~a set %i private-key ~a~{ peer ~a preshared-key ~a~}
-~a
-~a
-~a
-~a
-~a
-~{~a~^~%~}"
-                               #$(string-join addresses ",")
-                               #$(if table
-                                     (format #f "Table = ~a" table)
-                                     "")
-                               #$(if (null? pre-up)
-                                     ""
-                                     (string-join
-                                      (map (lambda (command)
-                                             (format #f "PreUp = ~a" command))
-                                           pre-up)
-                                      "\n"))
-                               #$(file-append wireguard "/bin/wg")
-                               #$private-key
-                               '#$peer-keys
-                               #$(if (null? post-up)
-                                     ""
-                                     (string-join
-                                      (map (lambda (command)
-                                             (format #f "PostUp = ~a" command))
-                                           post-up)
-                                      "\n"))
-                               #$(if (null? pre-down)
-                                     ""
-                                     (string-join
-                                      (map (lambda (command)
-                                             (format #f "PreDown = ~a" command))
-                                           pre-down)
-                                      "\n"))
-                               #$(if (null? post-down)
-                                     ""
-                                     (string-join
-                                      (map (lambda (command)
-                                             (format #f "PostDown = ~a" command))
-                                           post-down)
-                                      "\n"))
-                               #$(if port
-                                     (format #f "ListenPort = ~a" port)
-                                     "")
-                               #$(if dns
-                                     (format #f "DNS = ~a"
-                                             (string-join dns ","))
-                                     "")
-                               (list #$@peers)))))))))
+                     (format port "~a~%~%~{~a~%~^~%~}"
+                             (string-join (remove string-null? lines) "\n")
+                             '#$peers)))))))
       (file-append config "/" config-file))))
 
 (define (wireguard-activation config)
@@ -871,6 +851,58 @@ PostUp = ~a set %i private-key ~a~{ peer ~a preshared-key ~a~}
             (chmod #$private-key #o400)
             (close-pipe pipe))))))
 
+;;; XXX: Copied from (guix scripts pack), changing define to define*.
+(define-syntax-rule (define-with-source (variable args ...) body body* ...)
+  "Bind VARIABLE to a procedure accepting ARGS defined as BODY, also setting
+its source property."
+  (begin
+    (define* (variable args ...)
+      body body* ...)
+    (eval-when (load eval)
+      (set-procedure-property! variable 'source
+                               '(define* (variable args ...) body body* ...)))))
+
+(define (wireguard-service-name interface)
+  "Return the WireGuard service name (a symbol) configured to use INTERFACE."
+  (symbol-append 'wireguard- (string->symbol interface)))
+
+(define-with-source (strip-port/maybe endpoint #:key ipv6?)
+  "Strip the colon and port, if present in ENDPOINT, a string."
+  (if ipv6?
+      (if (string-prefix? "[" endpoint)
+          (first (string-split (string-drop endpoint 1) #\])) ;ipv6
+          endpoint)
+      (first (string-split endpoint #\:)))) ;ipv4
+
+(define* (ipv4-address? address)
+  "Predicate to check whether ADDRESS is a valid IPv4 address."
+  (let ((address (strip-port/maybe address)))
+    (false-if-exception
+     (->bool (getaddrinfo address #f AI_NUMERICHOST AF_INET)))))
+
+(define* (ipv6-address? address)
+  "Predicate to check whether ADDRESS is a valid IPv6 address."
+  (let ((address (strip-port/maybe address #:ipv6? #t)))
+    (false-if-exception
+     (->bool (getaddrinfo address #f AI_NUMERICHOST AF_INET6)))))
+
+(define (host-name? name)
+  "Predicate to check whether NAME is a host name, i.e. not an IP address."
+  (not (or (ipv6-address? name) (ipv4-address? name))))
+
+(define (endpoint-host-names peers)
+  "Return an association list of endpoint host names keyed by their peer
+public key, if any."
+  (reverse
+   (fold (lambda (peer host-names)
+           (let ((public-key (wireguard-peer-public-key peer))
+                 (endpoint (wireguard-peer-endpoint peer)))
+             (if (and endpoint (host-name? endpoint))
+                 (cons (cons public-key endpoint) host-names)
+                 host-names)))
+         '()
+         peers)))
+
 (define (wireguard-shepherd-service config)
   (match-record config <wireguard-configuration>
     (wireguard interface)
@@ -878,16 +910,96 @@ PostUp = ~a set %i private-key ~a~{ peer ~a preshared-key ~a~}
           (config (wireguard-configuration-file config)))
       (list (shepherd-service
              (requirement '(networking))
-             (provision (list
-                         (symbol-append 'wireguard-
-                                        (string->symbol interface))))
+             (provision (list (wireguard-service-name interface)))
              (start #~(lambda _
                        (invoke #$wg-quick "up" #$config)))
              (stop #~(lambda _
                        (invoke #$wg-quick "down" #$config)
                        #f))                       ;stopped!
+             (actions (list (shepherd-configuration-action config)))
              (documentation "Run the Wireguard VPN tunnel"))))))
 
+(define (wireguard-monitoring-jobs config)
+  ;; Loosely based on WireGuard's own 'reresolve-dns.sh' shell script (see:
+  ;; https://raw.githubusercontent.com/WireGuard/wireguard-tools/
+  ;; master/contrib/reresolve-dns/reresolve-dns.sh).
+  (match-record config <wireguard-configuration>
+    (interface monitor-ips? monitor-ips-interval peers)
+    (let ((host-names (endpoint-host-names peers)))
+      (if monitor-ips?
+          (if (null? host-names)
+              (begin
+                (warn "monitor-ips? is #t but no host name to monitor")
+                '())
+              ;; The mcron monitor job may be a string or a list; ungexp strips
+              ;; one quote level, which must be added back when a list is
+              ;; provided.
+              (list
+               #~(job
+                  (if (string? #$monitor-ips-interval)
+                      #$monitor-ips-interval
+                      '#$monitor-ips-interval)
+                  #$(program-file
+                     (format #f "wireguard-~a-monitoring" interface)
+                     (with-imported-modules (source-module-closure
+                                             '((gnu services herd)
+                                               (guix build utils)))
+                       #~(begin
+                           (use-modules (gnu services herd)
+                                        (guix build utils)
+                                        (ice-9 popen)
+                                        (ice-9 match)
+                                        (ice-9 textual-ports)
+                                        (srfi srfi-1)
+                                        (srfi srfi-26))
+
+                           (define (resolve-host name)
+                             "Return the IP address resolved from NAME."
+                             (let* ((ai (car (getaddrinfo name)))
+                                    (sa (addrinfo:addr ai)))
+                               (inet-ntop (sockaddr:fam sa)
+                                          (sockaddr:addr sa))))
+
+                           (define wg #$(file-append wireguard-tools "/bin/wg"))
+
+                           #$(procedure-source strip-port/maybe)
+
+                           (define service-name '#$(wireguard-service-name
+                                                    interface))
+
+                           (when (live-service-running
+                                  (current-service service-name))
+                             (let* ((pipe (open-pipe* OPEN_READ wg "show"
+                                                      #$interface "endpoints"))
+                                    (lines (string-split (get-string-all pipe)
+                                                         #\newline))
+                                    ;; IPS is an association list mapping
+                                    ;; public keys to IP addresses.
+                                    (ips (map (match-lambda
+                                                ((public-key ip)
+                                                 (cons public-key
+                                                       (strip-port/maybe ip))))
+                                              (map (cut string-split <> #\tab)
+                                                   (remove string-null?
+                                                           lines)))))
+                               (close-pipe pipe)
+                               (for-each
+                                (match-lambda
+                                  ((key . host-name)
+                                   (let ((resolved-ip (resolve-host
+                                                       (strip-port/maybe
+                                                        host-name)))
+                                         (current-ip (assoc-ref ips key)))
+                                     (unless (string=? resolved-ip current-ip)
+                                       (format #t "resetting `~a' peer \
+endpoint to `~a' due to stale IP (`~a' instead of `~a')~%"
+                                               key host-name
+                                               current-ip resolved-ip)
+                                       (invoke wg "set" #$interface "peer" key
+                                               "endpoint" host-name)))))
+                                '#$host-names)))))))))
+          '()))))                     ;monitor-ips? is #f
+
 (define wireguard-service-type
   (service-type
    (name 'wireguard)
@@ -898,6 +1010,8 @@ PostUp = ~a set %i private-key ~a~{ peer ~a preshared-key ~a~}
                              wireguard-activation)
           (service-extension profile-service-type
                              (compose list
-                                      wireguard-configuration-wireguard))))
+                                      wireguard-configuration-wireguard))
+          (service-extension mcron-service-type
+                             wireguard-monitoring-jobs)))
    (description "Set up Wireguard @acronym{VPN, Virtual Private Network}
 tunnels.")))