gnu/services/networking.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (gnu services networking)
  21   #:use-module (gnu services)
  22   #:use-module (gnu system shadow)
  23   #:use-module (gnu packages admin)
  24   #:use-module (gnu packages linux)
  25   #:use-module (gnu packages tor)
  26   #:use-module (gnu packages messaging)
  27   #:use-module (gnu packages ntp)
  28   #:use-module (gnu packages wicd)
  29   #:use-module (guix gexp)
  30   #:use-module (guix store)
  31   #:use-module (srfi srfi-26)
  32   #:export (%facebook-host-aliases
  33             static-networking-service
  34             dhcp-client-service
  35             %ntp-servers
  36             ntp-service
  37             tor-service
  38             bitlbee-service
  39             wicd-service))
  40
  41 ;;; Commentary:
  42 ;;;
  43 ;;; Networking services.
  44 ;;;
  45 ;;; Code:
  46
  47 (define %facebook-host-aliases
  48   ;; This is the list of known Facebook hosts to be added to /etc/hosts if you
  49   ;; are to block it.
  50   "\
  51 # Block Facebook IPv4.
  52 127.0.0.1   www.facebook.com
  53 127.0.0.1   facebook.com
  54 127.0.0.1   login.facebook.com
  55 127.0.0.1   www.login.facebook.com
  56 127.0.0.1   fbcdn.net
  57 127.0.0.1   www.fbcdn.net
  58 127.0.0.1   fbcdn.com
  59 127.0.0.1   www.fbcdn.com
  60 127.0.0.1   static.ak.fbcdn.net
  61 127.0.0.1   static.ak.connect.facebook.com
  62 127.0.0.1   connect.facebook.net
  63 127.0.0.1   www.connect.facebook.net
  64 127.0.0.1   apps.facebook.com
  65
  66 # Block Facebook IPv6.
  67 fe80::1%lo0 facebook.com
  68 fe80::1%lo0 login.facebook.com
  69 fe80::1%lo0 www.login.facebook.com
  70 fe80::1%lo0 fbcdn.net
  71 fe80::1%lo0 www.fbcdn.net
  72 fe80::1%lo0 fbcdn.com
  73 fe80::1%lo0 www.fbcdn.com
  74 fe80::1%lo0 static.ak.fbcdn.net
  75 fe80::1%lo0 static.ak.connect.facebook.com
  76 fe80::1%lo0 connect.facebook.net
  77 fe80::1%lo0 www.connect.facebook.net
  78 fe80::1%lo0 apps.facebook.com\n")
  79
  80
  81 (define* (static-networking-service interface ip
  82                                     #:key
  83                                     gateway
  84                                     (provision '(networking))
  85                                     (name-servers '())
  86                                     (net-tools net-tools))
  87   "Return a service that starts @var{interface} with address @var{ip}.  If
  88 @var{gateway} is true, it must be a string specifying the default network
  89 gateway."
  90   (define loopback?
  91     (memq 'loopback provision))
  92
  93   ;; TODO: Eventually replace 'route' with bindings for the appropriate
  94   ;; ioctls.
  95   (service
  96
  97    ;; Unless we're providing the loopback interface, wait for udev to be up
  98    ;; and running so that INTERFACE is actually usable.
  99    (requirement (if loopback? '() '(udev)))
 100
 101    (documentation
 102     "Bring up the networking interface using a static IP address.")
 103    (provision provision)
 104    (start #~(lambda _
 105               ;; Return #t if successfully started.
 106               (let* ((addr     (inet-pton AF_INET #$ip))
 107                      (sockaddr (make-socket-address AF_INET addr 0)))
 108                 (configure-network-interface #$interface sockaddr
 109                                              (logior IFF_UP
 110                                                      #$(if loopback?
 111                                                            #~IFF_LOOPBACK
 112                                                            0))))
 113               #$(if gateway
 114                     #~(zero? (system* (string-append #$net-tools
 115                                                      "/sbin/route")
 116                                       "add" "-net" "default"
 117                                       "gw" #$gateway))
 118                     #t)
 119               #$(if (pair? name-servers)
 120                     #~(call-with-output-file "/etc/resolv.conf"
 121                         (lambda (port)
 122                           (display
 123                            "# Generated by 'static-networking-service'.\n"
 124                            port)
 125                           (for-each (lambda (server)
 126                                       (format port "nameserver ~a~%"
 127                                               server))
 128                                     '#$name-servers)))
 129                     #t)))
 130    (stop #~(lambda _
 131              ;; Return #f is successfully stopped.
 132              (let ((sock (socket AF_INET SOCK_STREAM 0)))
 133                (set-network-interface-flags sock #$interface 0)
 134                (close-port sock))
 135              (not #$(if gateway
 136                         #~(system* (string-append #$net-tools
 137                                                   "/sbin/route")
 138                                    "del" "-net" "default")
 139                         #t))))
 140    (respawn? #f)))
 141
 142 (define* (dhcp-client-service #:key (dhcp isc-dhcp))
 143   "Return a service that runs @var{dhcp}, a Dynamic Host Configuration
 144 Protocol (DHCP) client, on all the non-loopback network interfaces."
 145
 146   (define dhclient
 147     #~(string-append #$dhcp "/sbin/dhclient"))
 148
 149   (define pid-file
 150     "/var/run/dhclient.pid")
 151
 152   (service
 153    (documentation "Set up networking via DHCP.")
 154    (requirement '(user-processes udev))
 155
 156    ;; XXX: Running with '-nw' ("no wait") avoids blocking for a minute when
 157    ;; networking is unavailable, but also means that the interface is not up
 158    ;; yet when 'start' completes.  To wait for the interface to be ready, one
 159    ;; should instead monitor udev events.
 160    (provision '(networking))
 161
 162    (start #~(lambda _
 163               ;; When invoked without any arguments, 'dhclient' discovers all
 164               ;; non-loopback interfaces *that are up*.  However, the relevant
 165               ;; interfaces are typically down at this point.  Thus we perform
 166               ;; our own interface discovery here.
 167               (define valid?
 168                 (negate loopback-network-interface?))
 169               (define ifaces
 170                 (filter valid? (all-network-interface-names)))
 171
 172               ;; XXX: Make sure the interfaces are up so that 'dhclient' can
 173               ;; actually send/receive over them.
 174               (for-each set-network-interface-up ifaces)
 175
 176               (false-if-exception (delete-file #$pid-file))
 177               (let ((pid (fork+exec-command
 178                           (cons* #$dhclient "-nw"
 179                                  "-pf" #$pid-file ifaces))))
 180                 (and (zero? (cdr (waitpid pid)))
 181                      (let loop ()
 182                        (catch 'system-error
 183                          (lambda ()
 184                            (call-with-input-file #$pid-file read))
 185                          (lambda args
 186                            ;; 'dhclient' returned before PID-FILE was created,
 187                            ;; so try again.
 188                            (let ((errno (system-error-errno args)))
 189                              (if (= ENOENT errno)
 190                                  (begin
 191                                    (sleep 1)
 192                                    (loop))
 193                                  (apply throw args))))))))))
 194    (stop #~(make-kill-destructor))))
 195
 196 (define %ntp-servers
 197   ;; Default set of NTP servers.
 198   '("0.pool.ntp.org"
 199     "1.pool.ntp.org"
 200     "2.pool.ntp.org"))
 201
 202 (define* (ntp-service #:key (ntp ntp)
 203                       (servers %ntp-servers))
 204   "Return a service that runs the daemon from @var{ntp}, the
 205 @uref{http://www.ntp.org, Network Time Protocol package}.  The daemon will
 206 keep the system clock synchronized with that of @var{servers}."
 207   ;; TODO: Add authentication support.
 208
 209   (define config
 210     (string-append "driftfile /var/run/ntp.drift\n"
 211                    (string-join (map (cut string-append "server " <>)
 212                                      servers)
 213                                 "\n")
 214                    "
 215 # Disable status queries as a workaround for CVE-2013-5211:
 216 # <http://support.ntp.org/bin/view/Main/SecurityNotice#DRDoS_Amplification_Attack_using>.
 217 restrict default kod nomodify notrap nopeer noquery
 218 restrict -6 default kod nomodify notrap nopeer noquery
 219
 220 # Yet, allow use of the local 'ntpq'.
 221 restrict 127.0.0.1
 222 restrict -6 ::1\n"))
 223
 224   (let ((ntpd.conf (plain-file "ntpd.conf" config)))
 225     (service
 226      (provision '(ntpd))
 227      (documentation "Run the Network Time Protocol (NTP) daemon.")
 228      (requirement '(user-processes networking))
 229      (start #~(make-forkexec-constructor
 230                (list (string-append #$ntp "/bin/ntpd") "-n"
 231                      "-c" #$ntpd.conf
 232                      "-u" "ntpd")))
 233      (stop #~(make-kill-destructor))
 234      (user-accounts (list (user-account
 235                            (name "ntpd")
 236                            (group "nogroup")
 237                            (system? #t)
 238                            (comment "NTP daemon user")
 239                            (home-directory "/var/empty")
 240                            (shell
 241                             #~(string-append #$shadow "/sbin/nologin"))))))))
 242
 243 (define* (tor-service #:key (tor tor))
 244   "Return a service to run the @uref{https://torproject.org,Tor} daemon.
 245
 246 The daemon runs with the default settings (in particular the default exit
 247 policy) as the @code{tor} unprivileged user."
 248   (let ((torrc (plain-file "torrc" "User tor\n")))
 249     (service
 250      (provision '(tor))
 251
 252      ;; Tor needs at least one network interface to be up, hence the
 253      ;; dependency on 'loopback'.
 254      (requirement '(user-processes loopback))
 255
 256      (start #~(make-forkexec-constructor
 257                (list (string-append #$tor "/bin/tor") "-f" #$torrc)))
 258      (stop #~(make-kill-destructor))
 259
 260      (user-groups   (list (user-group
 261                            (name "tor")
 262                            (system? #t))))
 263      (user-accounts (list (user-account
 264                            (name "tor")
 265                            (group "tor")
 266                            (system? #t)
 267                            (comment "Tor daemon user")
 268                            (home-directory "/var/empty")
 269                            (shell
 270                             #~(string-append #$shadow "/sbin/nologin")))))
 271
 272      (documentation "Run the Tor anonymous network overlay."))))
 273
 274 (define* (bitlbee-service #:key (bitlbee bitlbee)
 275                           (interface "127.0.0.1") (port 6667)
 276                           (extra-settings ""))
 277   "Return a service that runs @url{http://bitlbee.org,BitlBee}, a daemon that
 278 acts as a gateway between IRC and chat networks.
 279
 280 The daemon will listen to the interface corresponding to the IP address
 281 specified in @var{interface}, on @var{port}.  @code{127.0.0.1} means that only
 282 local clients can connect, whereas @code{0.0.0.0} means that connections can
 283 come from any networking interface.
 284
 285 In addition, @var{extra-settings} specifies a string to append to the
 286 configuration file."
 287   (let ((conf (plain-file "bitlbee.conf"
 288                           (string-append "
 289   [settings]
 290   User = bitlbee
 291   ConfigDir = /var/lib/bitlbee
 292   DaemonInterface = " interface "
 293   DaemonPort = " (number->string port) "
 294 " extra-settings))))
 295     (service
 296      (provision '(bitlbee))
 297      (requirement '(user-processes loopback))
 298      (activate #~(begin
 299                    (use-modules (guix build utils))
 300
 301                    ;; This directory is used to store OTR data.
 302                    (mkdir-p "/var/lib/bitlbee")
 303                    (let ((user (getpwnam "bitlbee")))
 304                      (chown "/var/lib/bitlbee"
 305                             (passwd:uid user) (passwd:gid user)))))
 306      (start #~(make-forkexec-constructor
 307                (list (string-append #$bitlbee "/sbin/bitlbee")
 308                      "-n" "-F" "-u" "bitlbee" "-c" #$conf)))
 309      (stop  #~(make-kill-destructor))
 310      (user-groups   (list (user-group (name "bitlbee") (system? #t))))
 311      (user-accounts (list (user-account
 312                            (name "bitlbee")
 313                            (group "bitlbee")
 314                            (system? #t)
 315                            (comment "BitlBee daemon user")
 316                            (home-directory "/var/empty")
 317                            (shell #~(string-append #$shadow
 318                                                    "/sbin/nologin"))))))))
 319
 320 (define* (wicd-service #:key (wicd wicd))
 321   "Return a service that runs @url{https://launchpad.net/wicd,Wicd}, a network
 322 manager that aims to simplify wired and wireless networking."
 323   (service
 324    (documentation "Run the Wicd network manager.")
 325    (provision '(networking))
 326    (requirement '(user-processes dbus-system loopback))
 327    (start #~(make-forkexec-constructor
 328              (list (string-append #$wicd "/sbin/wicd")
 329                    "--no-daemon")))
 330    (stop #~(make-kill-destructor))
 331    (activate
 332     #~(begin
 333         (use-modules (guix build utils))
 334         (mkdir-p "/etc/wicd")
 335         (let ((file-name "/etc/wicd/dhclient.conf.template.default"))
 336           (unless (file-exists? file-name)
 337             (copy-file (string-append #$wicd file-name)
 338                        file-name)))))))
 339
 340 ;;; networking.scm ends here