;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès ;;; Copyright © 2015 Mark H Weaver ;;; ;;; This file is part of GNU Guix. ;;; ;;; GNU Guix is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or (at ;;; your option) any later version. ;;; ;;; GNU Guix is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see . (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) #:use-module (gnu packages messaging) #:use-module (gnu packages ntp) #:use-module (gnu packages wicd) #:use-module (guix gexp) #:use-module (guix records) #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:export (%facebook-host-aliases static-networking-service dhcp-client-service %ntp-servers ntp-service tor-service bitlbee-service wicd-service)) ;;; Commentary: ;;; ;;; Networking services. ;;; ;;; Code: (define %facebook-host-aliases ;; This is the list of known Facebook hosts to be added to /etc/hosts if you ;; are to block it. "\ # Block Facebook IPv4. 127.0.0.1 www.facebook.com 127.0.0.1 facebook.com 127.0.0.1 login.facebook.com 127.0.0.1 www.login.facebook.com 127.0.0.1 fbcdn.net 127.0.0.1 www.fbcdn.net 127.0.0.1 fbcdn.com 127.0.0.1 www.fbcdn.com 127.0.0.1 static.ak.fbcdn.net 127.0.0.1 static.ak.connect.facebook.com 127.0.0.1 connect.facebook.net 127.0.0.1 www.connect.facebook.net 127.0.0.1 apps.facebook.com # Block Facebook IPv6. fe80::1%lo0 facebook.com fe80::1%lo0 login.facebook.com fe80::1%lo0 www.login.facebook.com fe80::1%lo0 fbcdn.net fe80::1%lo0 www.fbcdn.net fe80::1%lo0 fbcdn.com fe80::1%lo0 www.fbcdn.com fe80::1%lo0 static.ak.fbcdn.net fe80::1%lo0 static.ak.connect.facebook.com fe80::1%lo0 connect.facebook.net fe80::1%lo0 www.connect.facebook.net fe80::1%lo0 apps.facebook.com\n") (define-record-type* 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 'static-networking (match-lambda (($ 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 (provision '(networking)) (name-servers '()) (net-tools net-tools)) "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." (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 'dhcp-client (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." (service dhcp-client-service-type dhcp)) (define %ntp-servers ;; Default set of NTP servers. '("0.pool.ntp.org" "1.pool.ntp.org" "2.pool.ntp.org")) ;;; ;;; NTP. ;;; ;; TODO: Export. (define-record-type* ntp-configuration make-ntp-configuration ntp-configuration? (ntp ntp-configuration-ntp (default ntp)) (servers ntp-configuration-servers)) (define ntp-dmd-service (match-lambda (($ 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: # . restrict default kod nomodify notrap nopeer noquery restrict -6 default kod nomodify notrap nopeer noquery # Yet, allow use of the local 'ntpq'. restrict 127.0.0.1 restrict -6 ::1\n")) (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 config) "Return a running TOR." (match config ((tor config-file) (let ((torrc (computed-file "torrc" #~(begin (use-modules (guix build utils)) (call-with-output-file #$output (lambda (port) (display "\ User tor # automatically added\n" port) (call-with-input-file #$config-file (lambda (input) (dump-port input port))) #t))) #:modules '((guix build utils))))) (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 #:optional (config-file (plain-file "empty" "")) #:key (tor tor)) "Return a service to run the @uref{https://torproject.org, Tor} anonymous networking daemon. The daemon runs as the @code{tor} unprivileged user. It is passed @var{config-file}, a file-like object, with an additional @code{User tor} line. Run @command{man tor} for information about the configuration file." (service tor-service-type (list tor config-file))) ;;; ;;; BitlBee. ;;; (define-record-type* 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 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) (extra-settings "")) "Return a service that runs @url{http://bitlbee.org,BitlBee}, a daemon that acts as a gateway between IRC and chat networks. The daemon will listen to the interface corresponding to the IP address specified in @var{interface}, on @var{port}. @code{127.0.0.1} means that only local clients can connect, whereas @code{0.0.0.0} means that connections can come from any networking interface. In addition, @var{extra-settings} specifies a string to append to the configuration file." (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)) ;; Add Wicd to the global profile. (service-extension profile-service-type list))))) (define* (wicd-service #:key (wicd wicd)) "Return a service that runs @url{https://launchpad.net/wicd,Wicd}, a network management daemon that aims to simplify wired and wireless networking. This service adds the @var{wicd} package to the global profile, providing several commands to interact with the daemon and configure networking: @command{wicd-client}, a graphical user interface, and the @command{wicd-cli} and @command{wicd-curses} user interfaces." (service wicd-service-type wicd)) ;;; networking.scm ends here