diff options
Diffstat (limited to 'gnu/services/networking.scm')
| -rw-r--r-- | gnu/services/networking.scm | 546 |
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 |