summaryrefslogtreecommitdiff
path: root/gnu/services/networking.scm
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/services/networking.scm')
-rw-r--r--gnu/services/networking.scm546
1 files changed, 340 insertions, 206 deletions
diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm
index 50ffac5796..52a843b54b 100644
--- a/gnu/services/networking.scm
+++ b/gnu/services/networking.scm
@@ -19,7 +19,10 @@
(define-module (gnu services networking)
#:use-module (gnu services)
+ #:use-module (gnu services dmd)
+ #:use-module (gnu services dbus)
#:use-module (gnu system shadow)
+ #:use-module (gnu system linux) ;PAM
#:use-module (gnu packages admin)
#:use-module (gnu packages linux)
#:use-module (gnu packages tor)
@@ -27,8 +30,9 @@
#:use-module (gnu packages ntp)
#:use-module (gnu packages wicd)
#:use-module (guix gexp)
- #:use-module (guix store)
+ #:use-module (guix records)
#:use-module (srfi srfi-26)
+ #:use-module (ice-9 match)
#:export (%facebook-host-aliases
static-networking-service
dhcp-client-service
@@ -78,6 +82,72 @@ fe80::1%lo0 www.connect.facebook.net
fe80::1%lo0 apps.facebook.com\n")
+(define-record-type* <static-networking>
+ static-networking make-static-networking
+ static-networking?
+ (interface static-networking-interface)
+ (ip static-networking-ip)
+ (gateway static-networking-gateway)
+ (provision static-networking-provision)
+ (name-servers static-networking-name-servers)
+ (net-tools static-networking-net-tools))
+
+(define static-networking-service-type
+ (dmd-service-type
+ (match-lambda
+ (($ <static-networking> interface ip gateway provision
+ name-servers net-tools)
+ (let ((loopback? (memq 'loopback provision)))
+
+ ;; TODO: Eventually replace 'route' with bindings for the appropriate
+ ;; ioctls.
+ (dmd-service
+
+ ;; Unless we're providing the loopback interface, wait for udev to be up
+ ;; and running so that INTERFACE is actually usable.
+ (requirement (if loopback? '() '(udev)))
+
+ (documentation
+ "Bring up the networking interface using a static IP address.")
+ (provision provision)
+ (start #~(lambda _
+ ;; Return #t if successfully started.
+ (let* ((addr (inet-pton AF_INET #$ip))
+ (sockaddr (make-socket-address AF_INET addr 0)))
+ (configure-network-interface #$interface sockaddr
+ (logior IFF_UP
+ #$(if loopback?
+ #~IFF_LOOPBACK
+ 0))))
+ #$(if gateway
+ #~(zero? (system* (string-append #$net-tools
+ "/sbin/route")
+ "add" "-net" "default"
+ "gw" #$gateway))
+ #t)
+ #$(if (pair? name-servers)
+ #~(call-with-output-file "/etc/resolv.conf"
+ (lambda (port)
+ (display
+ "# Generated by 'static-networking-service'.\n"
+ port)
+ (for-each (lambda (server)
+ (format port "nameserver ~a~%"
+ server))
+ '#$name-servers)))
+ #t)))
+ (stop #~(lambda _
+ ;; Return #f is successfully stopped.
+ (let ((sock (socket AF_INET SOCK_STREAM 0)))
+ (set-network-interface-flags sock #$interface 0)
+ (close-port sock))
+ (not #$(if gateway
+ #~(system* (string-append #$net-tools
+ "/sbin/route")
+ "del" "-net" "default")
+ #t))))
+ (respawn? #f)))))))
+
(define* (static-networking-service interface ip
#:key
gateway
@@ -87,111 +157,70 @@ fe80::1%lo0 apps.facebook.com\n")
"Return a service that starts @var{interface} with address @var{ip}. If
@var{gateway} is true, it must be a string specifying the default network
gateway."
- (define loopback?
- (memq 'loopback provision))
-
- ;; TODO: Eventually replace 'route' with bindings for the appropriate
- ;; ioctls.
- (service
-
- ;; Unless we're providing the loopback interface, wait for udev to be up
- ;; and running so that INTERFACE is actually usable.
- (requirement (if loopback? '() '(udev)))
-
- (documentation
- "Bring up the networking interface using a static IP address.")
- (provision provision)
- (start #~(lambda _
- ;; Return #t if successfully started.
- (let* ((addr (inet-pton AF_INET #$ip))
- (sockaddr (make-socket-address AF_INET addr 0)))
- (configure-network-interface #$interface sockaddr
- (logior IFF_UP
- #$(if loopback?
- #~IFF_LOOPBACK
- 0))))
- #$(if gateway
- #~(zero? (system* (string-append #$net-tools
- "/sbin/route")
- "add" "-net" "default"
- "gw" #$gateway))
- #t)
- #$(if (pair? name-servers)
- #~(call-with-output-file "/etc/resolv.conf"
- (lambda (port)
- (display
- "# Generated by 'static-networking-service'.\n"
- port)
- (for-each (lambda (server)
- (format port "nameserver ~a~%"
- server))
- '#$name-servers)))
- #t)))
- (stop #~(lambda _
- ;; Return #f is successfully stopped.
- (let ((sock (socket AF_INET SOCK_STREAM 0)))
- (set-network-interface-flags sock #$interface 0)
- (close-port sock))
- (not #$(if gateway
- #~(system* (string-append #$net-tools
- "/sbin/route")
- "del" "-net" "default")
- #t))))
- (respawn? #f)))
+ (service static-networking-service-type
+ (static-networking (interface interface) (ip ip)
+ (gateway gateway)
+ (provision provision)
+ (name-servers name-servers)
+ (net-tools net-tools))))
+
+(define dhcp-client-service-type
+ (dmd-service-type
+ (lambda (dhcp)
+ (define dhclient
+ #~(string-append #$dhcp "/sbin/dhclient"))
+
+ (define pid-file
+ "/var/run/dhclient.pid")
+
+ (dmd-service
+ (documentation "Set up networking via DHCP.")
+ (requirement '(user-processes udev))
+
+ ;; XXX: Running with '-nw' ("no wait") avoids blocking for a minute when
+ ;; networking is unavailable, but also means that the interface is not up
+ ;; yet when 'start' completes. To wait for the interface to be ready, one
+ ;; should instead monitor udev events.
+ (provision '(networking))
+
+ (start #~(lambda _
+ ;; When invoked without any arguments, 'dhclient' discovers all
+ ;; non-loopback interfaces *that are up*. However, the relevant
+ ;; interfaces are typically down at this point. Thus we perform
+ ;; our own interface discovery here.
+ (define valid?
+ (negate loopback-network-interface?))
+ (define ifaces
+ (filter valid? (all-network-interface-names)))
+
+ ;; XXX: Make sure the interfaces are up so that 'dhclient' can
+ ;; actually send/receive over them.
+ (for-each set-network-interface-up ifaces)
+
+ (false-if-exception (delete-file #$pid-file))
+ (let ((pid (fork+exec-command
+ (cons* #$dhclient "-nw"
+ "-pf" #$pid-file ifaces))))
+ (and (zero? (cdr (waitpid pid)))
+ (let loop ()
+ (catch 'system-error
+ (lambda ()
+ (call-with-input-file #$pid-file read))
+ (lambda args
+ ;; 'dhclient' returned before PID-FILE was created,
+ ;; so try again.
+ (let ((errno (system-error-errno args)))
+ (if (= ENOENT errno)
+ (begin
+ (sleep 1)
+ (loop))
+ (apply throw args))))))))))
+ (stop #~(make-kill-destructor))))))
(define* (dhcp-client-service #:key (dhcp isc-dhcp))
"Return a service that runs @var{dhcp}, a Dynamic Host Configuration
Protocol (DHCP) client, on all the non-loopback network interfaces."
-
- (define dhclient
- #~(string-append #$dhcp "/sbin/dhclient"))
-
- (define pid-file
- "/var/run/dhclient.pid")
-
- (service
- (documentation "Set up networking via DHCP.")
- (requirement '(user-processes udev))
-
- ;; XXX: Running with '-nw' ("no wait") avoids blocking for a minute when
- ;; networking is unavailable, but also means that the interface is not up
- ;; yet when 'start' completes. To wait for the interface to be ready, one
- ;; should instead monitor udev events.
- (provision '(networking))
-
- (start #~(lambda _
- ;; When invoked without any arguments, 'dhclient' discovers all
- ;; non-loopback interfaces *that are up*. However, the relevant
- ;; interfaces are typically down at this point. Thus we perform
- ;; our own interface discovery here.
- (define valid?
- (negate loopback-network-interface?))
- (define ifaces
- (filter valid? (all-network-interface-names)))
-
- ;; XXX: Make sure the interfaces are up so that 'dhclient' can
- ;; actually send/receive over them.
- (for-each set-network-interface-up ifaces)
-
- (false-if-exception (delete-file #$pid-file))
- (let ((pid (fork+exec-command
- (cons* #$dhclient "-nw"
- "-pf" #$pid-file ifaces))))
- (and (zero? (cdr (waitpid pid)))
- (let loop ()
- (catch 'system-error
- (lambda ()
- (call-with-input-file #$pid-file read))
- (lambda args
- ;; 'dhclient' returned before PID-FILE was created,
- ;; so try again.
- (let ((errno (system-error-errno args)))
- (if (= ENOENT errno)
- (begin
- (sleep 1)
- (loop))
- (apply throw args))))))))))
- (stop #~(make-kill-destructor))))
+ (service dhcp-client-service-type dhcp))
(define %ntp-servers
;; Default set of NTP servers.
@@ -199,19 +228,30 @@ Protocol (DHCP) client, on all the non-loopback network interfaces."
"1.pool.ntp.org"
"2.pool.ntp.org"))
-(define* (ntp-service #:key (ntp ntp)
- (servers %ntp-servers))
- "Return a service that runs the daemon from @var{ntp}, the
-@uref{http://www.ntp.org, Network Time Protocol package}. The daemon will
-keep the system clock synchronized with that of @var{servers}."
- ;; TODO: Add authentication support.
-
- (define config
- (string-append "driftfile /var/run/ntp.drift\n"
- (string-join (map (cut string-append "server " <>)
- servers)
- "\n")
- "
+
+;;;
+;;; NTP.
+;;;
+
+;; TODO: Export.
+(define-record-type* <ntp-configuration>
+ ntp-configuration make-ntp-configuration
+ ntp-configuration?
+ (ntp ntp-configuration-ntp
+ (default ntp))
+ (servers ntp-configuration-servers))
+
+(define ntp-dmd-service
+ (match-lambda
+ (($ <ntp-configuration> ntp servers)
+ (let ()
+ ;; TODO: Add authentication support.
+ (define config
+ (string-append "driftfile /var/run/ntp.drift\n"
+ (string-join (map (cut string-append "server " <>)
+ servers)
+ "\n")
+ "
# Disable status queries as a workaround for CVE-2013-5211:
# <http://support.ntp.org/bin/view/Main/SecurityNotice#DRDoS_Amplification_Attack_using>.
restrict default kod nomodify notrap nopeer noquery
@@ -221,55 +261,154 @@ restrict -6 default kod nomodify notrap nopeer noquery
restrict 127.0.0.1
restrict -6 ::1\n"))
- (let ((ntpd.conf (plain-file "ntpd.conf" config)))
- (service
- (provision '(ntpd))
- (documentation "Run the Network Time Protocol (NTP) daemon.")
- (requirement '(user-processes networking))
- (start #~(make-forkexec-constructor
- (list (string-append #$ntp "/bin/ntpd") "-n"
- "-c" #$ntpd.conf
- "-u" "ntpd")))
- (stop #~(make-kill-destructor))
- (user-accounts (list (user-account
- (name "ntpd")
- (group "nogroup")
- (system? #t)
- (comment "NTP daemon user")
- (home-directory "/var/empty")
- (shell
- #~(string-append #$shadow "/sbin/nologin"))))))))
+ (define ntpd.conf
+ (plain-file "ntpd.conf" config))
+
+ (list (dmd-service
+ (provision '(ntpd))
+ (documentation "Run the Network Time Protocol (NTP) daemon.")
+ (requirement '(user-processes networking))
+ (start #~(make-forkexec-constructor
+ (list (string-append #$ntp "/bin/ntpd") "-n"
+ "-c" #$ntpd.conf "-u" "ntpd")))
+ (stop #~(make-kill-destructor))))))))
+
+(define %ntp-accounts
+ (list (user-account
+ (name "ntpd")
+ (group "nogroup")
+ (system? #t)
+ (comment "NTP daemon user")
+ (home-directory "/var/empty")
+ (shell #~(string-append #$shadow "/sbin/nologin")))))
+
+(define ntp-service-type
+ (service-type (name 'ntp)
+ (extensions
+ (list (service-extension dmd-root-service-type
+ ntp-dmd-service)
+ (service-extension account-service-type
+ (const %ntp-accounts))))))
+
+(define* (ntp-service #:key (ntp ntp)
+ (servers %ntp-servers))
+ "Return a service that runs the daemon from @var{ntp}, the
+@uref{http://www.ntp.org, Network Time Protocol package}. The daemon will
+keep the system clock synchronized with that of @var{servers}."
+ (service ntp-service-type
+ (ntp-configuration (ntp ntp) (servers servers))))
+
+
+;;;
+;;; Tor.
+;;;
+
+(define %tor-accounts
+ ;; User account and groups for Tor.
+ (list (user-group (name "tor") (system? #t))
+ (user-account
+ (name "tor")
+ (group "tor")
+ (system? #t)
+ (comment "Tor daemon user")
+ (home-directory "/var/empty")
+ (shell #~(string-append #$shadow "/sbin/nologin")))))
+
+(define (tor-dmd-service tor)
+ "Return a <dmd-service> running TOR."
+ (let ((torrc (plain-file "torrc" "User tor\n")))
+ (list (dmd-service
+ (provision '(tor))
+
+ ;; Tor needs at least one network interface to be up, hence the
+ ;; dependency on 'loopback'.
+ (requirement '(user-processes loopback))
+
+ (start #~(make-forkexec-constructor
+ (list (string-append #$tor "/bin/tor") "-f" #$torrc)))
+ (stop #~(make-kill-destructor))
+ (documentation "Run the Tor anonymous network overlay.")))))
+
+(define tor-service-type
+ (service-type (name 'tor)
+ (extensions
+ (list (service-extension dmd-root-service-type
+ tor-dmd-service)
+ (service-extension account-service-type
+ (const %tor-accounts))))))
(define* (tor-service #:key (tor tor))
"Return a service to run the @uref{https://torproject.org,Tor} daemon.
The daemon runs with the default settings (in particular the default exit
policy) as the @code{tor} unprivileged user."
- (let ((torrc (plain-file "torrc" "User tor\n")))
- (service
- (provision '(tor))
-
- ;; Tor needs at least one network interface to be up, hence the
- ;; dependency on 'loopback'.
- (requirement '(user-processes loopback))
-
- (start #~(make-forkexec-constructor
- (list (string-append #$tor "/bin/tor") "-f" #$torrc)))
- (stop #~(make-kill-destructor))
-
- (user-groups (list (user-group
- (name "tor")
- (system? #t))))
- (user-accounts (list (user-account
- (name "tor")
- (group "tor")
- (system? #t)
- (comment "Tor daemon user")
- (home-directory "/var/empty")
- (shell
- #~(string-append #$shadow "/sbin/nologin")))))
-
- (documentation "Run the Tor anonymous network overlay."))))
+ (service tor-service-type tor))
+
+
+;;;
+;;; BitlBee.
+;;;
+
+(define-record-type* <bitlbee-configuration>
+ bitlbee-configuration make-bitlbee-configuration
+ bitlbee-configuration?
+ (bitlbee bitlbee-configuration-bitlbee
+ (default bitlbee))
+ (interface bitlbee-configuration-interface)
+ (port bitlbee-configuration-port)
+ (extra-settings bitlbee-configuration-extra-settings))
+
+(define bitlbee-dmd-service
+ (match-lambda
+ (($ <bitlbee-configuration> bitlbee interface port extra-settings)
+ (let ((conf (plain-file "bitlbee.conf"
+ (string-append "
+ [settings]
+ User = bitlbee
+ ConfigDir = /var/lib/bitlbee
+ DaemonInterface = " interface "
+ DaemonPort = " (number->string port) "
+" extra-settings))))
+
+ (list (dmd-service
+ (provision '(bitlbee))
+ (requirement '(user-processes loopback))
+ (start #~(make-forkexec-constructor
+ (list (string-append #$bitlbee "/sbin/bitlbee")
+ "-n" "-F" "-u" "bitlbee" "-c" #$conf)))
+ (stop #~(make-kill-destructor))))))))
+
+(define %bitlbee-accounts
+ ;; User group and account to run BitlBee.
+ (list (user-group (name "bitlbee") (system? #t))
+ (user-account
+ (name "bitlbee")
+ (group "bitlbee")
+ (system? #t)
+ (comment "BitlBee daemon user")
+ (home-directory "/var/empty")
+ (shell #~(string-append #$shadow "/sbin/nologin")))))
+
+(define %bitlbee-activation
+ ;; Activation gexp for BitlBee.
+ #~(begin
+ (use-modules (guix build utils))
+
+ ;; This directory is used to store OTR data.
+ (mkdir-p "/var/lib/bitlbee")
+ (let ((user (getpwnam "bitlbee")))
+ (chown "/var/lib/bitlbee"
+ (passwd:uid user) (passwd:gid user)))))
+
+(define bitlbee-service-type
+ (service-type (name 'bitlbee)
+ (extensions
+ (list (service-extension dmd-root-service-type
+ bitlbee-dmd-service)
+ (service-extension account-service-type
+ (const %bitlbee-accounts))
+ (service-extension activation-service-type
+ (const %bitlbee-activation))))))
(define* (bitlbee-service #:key (bitlbee bitlbee)
(interface "127.0.0.1") (port 6667)
@@ -284,57 +423,52 @@ come from any networking interface.
In addition, @var{extra-settings} specifies a string to append to the
configuration file."
- (let ((conf (plain-file "bitlbee.conf"
- (string-append "
- [settings]
- User = bitlbee
- ConfigDir = /var/lib/bitlbee
- DaemonInterface = " interface "
- DaemonPort = " (number->string port) "
-" extra-settings))))
- (service
- (provision '(bitlbee))
- (requirement '(user-processes loopback))
- (activate #~(begin
- (use-modules (guix build utils))
-
- ;; This directory is used to store OTR data.
- (mkdir-p "/var/lib/bitlbee")
- (let ((user (getpwnam "bitlbee")))
- (chown "/var/lib/bitlbee"
- (passwd:uid user) (passwd:gid user)))))
- (start #~(make-forkexec-constructor
- (list (string-append #$bitlbee "/sbin/bitlbee")
- "-n" "-F" "-u" "bitlbee" "-c" #$conf)))
- (stop #~(make-kill-destructor))
- (user-groups (list (user-group (name "bitlbee") (system? #t))))
- (user-accounts (list (user-account
- (name "bitlbee")
- (group "bitlbee")
- (system? #t)
- (comment "BitlBee daemon user")
- (home-directory "/var/empty")
- (shell #~(string-append #$shadow
- "/sbin/nologin"))))))))
+ (service bitlbee-service-type
+ (bitlbee-configuration
+ (bitlbee bitlbee)
+ (interface interface) (port port)
+ (extra-settings extra-settings))))
+
+
+;;;
+;;; Wicd.
+;;;
+
+(define %wicd-activation
+ ;; Activation gexp for Wicd.
+ #~(begin
+ (use-modules (guix build utils))
+
+ (mkdir-p "/etc/wicd")
+ (let ((file-name "/etc/wicd/dhclient.conf.template.default"))
+ (unless (file-exists? file-name)
+ (copy-file (string-append #$wicd file-name)
+ file-name)))))
+
+(define (wicd-dmd-service wicd)
+ "Return a dmd service for WICD."
+ (list (dmd-service
+ (documentation "Run the Wicd network manager.")
+ (provision '(networking))
+ (requirement '(user-processes dbus-system loopback))
+ (start #~(make-forkexec-constructor
+ (list (string-append #$wicd "/sbin/wicd")
+ "--no-daemon")))
+ (stop #~(make-kill-destructor)))))
+
+(define wicd-service-type
+ (service-type (name 'wicd)
+ (extensions
+ (list (service-extension dmd-root-service-type
+ wicd-dmd-service)
+ (service-extension dbus-root-service-type
+ list)
+ (service-extension activation-service-type
+ (const %wicd-activation))))))
(define* (wicd-service #:key (wicd wicd))
"Return a service that runs @url{https://launchpad.net/wicd,Wicd}, a network
manager that aims to simplify wired and wireless networking."
- (service
- (documentation "Run the Wicd network manager.")
- (provision '(networking))
- (requirement '(user-processes dbus-system loopback))
- (start #~(make-forkexec-constructor
- (list (string-append #$wicd "/sbin/wicd")
- "--no-daemon")))
- (stop #~(make-kill-destructor))
- (activate
- #~(begin
- (use-modules (guix build utils))
- (mkdir-p "/etc/wicd")
- (let ((file-name "/etc/wicd/dhclient.conf.template.default"))
- (unless (file-exists? file-name)
- (copy-file (string-append #$wicd file-name)
- file-name)))))))
+ (service wicd-service-type wicd))
;;; networking.scm ends here
generated by cgit v1.2.3 (git 2.45.2) at 2024-06-27 18:26:22 +0000