diff options
Diffstat (limited to 'gnu/services')
| -rw-r--r-- | gnu/services/base.scm | 9 | ||||
| -rw-r--r-- | gnu/services/herd.scm | 52 | ||||
| -rw-r--r-- | gnu/services/virtualization.scm | 4 | ||||
| -rw-r--r-- | gnu/services/vpn.scm | 268 |
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."))) |