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 services dmd)
  23   #:use-module (gnu services dbus)
  24   #:use-module (gnu system shadow)
  25   #:use-module (gnu system linux)                 ;PAM
  26   #:use-module (gnu packages admin)
  27   #:use-module (gnu packages linux)
  28   #:use-module (gnu packages tor)
  29   #:use-module (gnu packages messaging)
  30   #:use-module (gnu packages ntp)
  31   #:use-module (gnu packages wicd)
  32   #:use-module (guix gexp)
  33   #:use-module (guix records)
  34   #:use-module (srfi srfi-26)
  35   #:use-module (ice-9 match)
  36   #:export (%facebook-host-aliases
  37             static-networking-service
  38             dhcp-client-service
  39             %ntp-servers
  40             ntp-service
  41             tor-service
  42             bitlbee-service
  43             wicd-service))
  44
  45 ;;; Commentary:
  46 ;;;
  47 ;;; Networking services.
  48 ;;;
  49 ;;; Code:
  50
  51 (define %facebook-host-aliases
  52   ;; This is the list of known Facebook hosts to be added to /etc/hosts if you
  53   ;; are to block it.
  54   "\
  55 # Block Facebook IPv4.
  56 127.0.0.1   www.facebook.com
  57 127.0.0.1   facebook.com
  58 127.0.0.1   login.facebook.com
  59 127.0.0.1   www.login.facebook.com
  60 127.0.0.1   fbcdn.net
  61 127.0.0.1   www.fbcdn.net
  62 127.0.0.1   fbcdn.com
  63 127.0.0.1   www.fbcdn.com
  64 127.0.0.1   static.ak.fbcdn.net
  65 127.0.0.1   static.ak.connect.facebook.com
  66 127.0.0.1   connect.facebook.net
  67 127.0.0.1   www.connect.facebook.net
  68 127.0.0.1   apps.facebook.com
  69
  70 # Block Facebook IPv6.
  71 fe80::1%lo0 facebook.com
  72 fe80::1%lo0 login.facebook.com
  73 fe80::1%lo0 www.login.facebook.com
  74 fe80::1%lo0 fbcdn.net
  75 fe80::1%lo0 www.fbcdn.net
  76 fe80::1%lo0 fbcdn.com
  77 fe80::1%lo0 www.fbcdn.com
  78 fe80::1%lo0 static.ak.fbcdn.net
  79 fe80::1%lo0 static.ak.connect.facebook.com
  80 fe80::1%lo0 connect.facebook.net
  81 fe80::1%lo0 www.connect.facebook.net
  82 fe80::1%lo0 apps.facebook.com\n")
  83
  84
  85 (define-record-type* <static-networking>
  86   static-networking make-static-networking
  87   static-networking?
  88   (interface static-networking-interface)
  89   (ip static-networking-ip)
  90   (gateway static-networking-gateway)
  91   (provision static-networking-provision)
  92   (name-servers static-networking-name-servers)
  93   (net-tools static-networking-net-tools))
  94
  95 (define static-networking-service-type
  96   (dmd-service-type
  97    'static-networking
  98    (match-lambda
  99      (($ <static-networking> interface ip gateway provision
 100                              name-servers net-tools)
 101       (let ((loopback? (memq 'loopback provision)))
 102
 103         ;; TODO: Eventually replace 'route' with bindings for the appropriate
 104         ;; ioctls.
 105         (dmd-service
 106
 107          ;; Unless we're providing the loopback interface, wait for udev to be up
 108          ;; and running so that INTERFACE is actually usable.
 109          (requirement (if loopback? '() '(udev)))
 110
 111          (documentation
 112           "Bring up the networking interface using a static IP address.")
 113          (provision provision)
 114          (start #~(lambda _
 115                     ;; Return #t if successfully started.
 116                     (let* ((addr     (inet-pton AF_INET #$ip))
 117                            (sockaddr (make-socket-address AF_INET addr 0)))
 118                       (configure-network-interface #$interface sockaddr
 119                                                    (logior IFF_UP
 120                                                            #$(if loopback?
 121                                                                  #~IFF_LOOPBACK
 122                                                                  0))))
 123                     #$(if gateway
 124                           #~(zero? (system* (string-append #$net-tools
 125                                                            "/sbin/route")
 126                                             "add" "-net" "default"
 127                                             "gw" #$gateway))
 128                           #t)
 129                     #$(if (pair? name-servers)
 130                           #~(call-with-output-file "/etc/resolv.conf"
 131                               (lambda (port)
 132                                 (display
 133                                  "# Generated by 'static-networking-service'.\n"
 134                                  port)
 135                                 (for-each (lambda (server)
 136                                             (format port "nameserver ~a~%"
 137                                                     server))
 138                                           '#$name-servers)))
 139                           #t)))
 140          (stop #~(lambda _
 141                    ;; Return #f is successfully stopped.
 142                    (let ((sock (socket AF_INET SOCK_STREAM 0)))
 143                      (set-network-interface-flags sock #$interface 0)
 144                      (close-port sock))
 145                    (not #$(if gateway
 146                               #~(system* (string-append #$net-tools
 147                                                         "/sbin/route")
 148                                          "del" "-net" "default")
 149                               #t))))
 150          (respawn? #f)))))))
 151
 152 (define* (static-networking-service interface ip
 153                                     #:key
 154                                     gateway
 155                                     (provision '(networking))
 156                                     (name-servers '())
 157                                     (net-tools net-tools))
 158   "Return a service that starts @var{interface} with address @var{ip}.  If
 159 @var{gateway} is true, it must be a string specifying the default network
 160 gateway."
 161   (service static-networking-service-type
 162            (static-networking (interface interface) (ip ip)
 163                               (gateway gateway)
 164                               (provision provision)
 165                               (name-servers name-servers)
 166                               (net-tools net-tools))))
 167
 168 (define dhcp-client-service-type
 169   (dmd-service-type
 170    'dhcp-client
 171    (lambda (dhcp)
 172      (define dhclient
 173        #~(string-append #$dhcp "/sbin/dhclient"))
 174
 175      (define pid-file
 176        "/var/run/dhclient.pid")
 177
 178      (dmd-service
 179       (documentation "Set up networking via DHCP.")
 180       (requirement '(user-processes udev))
 181
 182       ;; XXX: Running with '-nw' ("no wait") avoids blocking for a minute when
 183       ;; networking is unavailable, but also means that the interface is not up
 184       ;; yet when 'start' completes.  To wait for the interface to be ready, one
 185       ;; should instead monitor udev events.
 186       (provision '(networking))
 187
 188       (start #~(lambda _
 189                  ;; When invoked without any arguments, 'dhclient' discovers all
 190                  ;; non-loopback interfaces *that are up*.  However, the relevant
 191                  ;; interfaces are typically down at this point.  Thus we perform
 192                  ;; our own interface discovery here.
 193                  (define valid?
 194                    (negate loopback-network-interface?))
 195                  (define ifaces
 196                    (filter valid? (all-network-interface-names)))
 197
 198                  ;; XXX: Make sure the interfaces are up so that 'dhclient' can
 199                  ;; actually send/receive over them.
 200                  (for-each set-network-interface-up ifaces)
 201
 202                  (false-if-exception (delete-file #$pid-file))
 203                  (let ((pid (fork+exec-command
 204                              (cons* #$dhclient "-nw"
 205                                     "-pf" #$pid-file ifaces))))
 206                    (and (zero? (cdr (waitpid pid)))
 207                         (let loop ()
 208                           (catch 'system-error
 209                             (lambda ()
 210                               (call-with-input-file #$pid-file read))
 211                             (lambda args
 212                               ;; 'dhclient' returned before PID-FILE was created,
 213                               ;; so try again.
 214                               (let ((errno (system-error-errno args)))
 215                                 (if (= ENOENT errno)
 216                                     (begin
 217                                       (sleep 1)
 218                                       (loop))
 219                                     (apply throw args))))))))))
 220       (stop #~(make-kill-destructor))))))
 221
 222 (define* (dhcp-client-service #:key (dhcp isc-dhcp))
 223   "Return a service that runs @var{dhcp}, a Dynamic Host Configuration
 224 Protocol (DHCP) client, on all the non-loopback network interfaces."
 225   (service dhcp-client-service-type dhcp))
 226
 227 (define %ntp-servers
 228   ;; Default set of NTP servers.
 229   '("0.pool.ntp.org"
 230     "1.pool.ntp.org"
 231     "2.pool.ntp.org"))
 232
 233 \f
 234 ;;;
 235 ;;; NTP.
 236 ;;;
 237
 238 ;; TODO: Export.
 239 (define-record-type* <ntp-configuration>
 240   ntp-configuration make-ntp-configuration
 241   ntp-configuration?
 242   (ntp      ntp-configuration-ntp
 243             (default ntp))
 244   (servers  ntp-configuration-servers))
 245
 246 (define ntp-dmd-service
 247   (match-lambda
 248     (($ <ntp-configuration> ntp servers)
 249      (let ()
 250        ;; TODO: Add authentication support.
 251        (define config
 252          (string-append "driftfile /var/run/ntp.drift\n"
 253                         (string-join (map (cut string-append "server " <>)
 254                                           servers)
 255                                      "\n")
 256                         "
 257 # Disable status queries as a workaround for CVE-2013-5211:
 258 # <http://support.ntp.org/bin/view/Main/SecurityNotice#DRDoS_Amplification_Attack_using>.
 259 restrict default kod nomodify notrap nopeer noquery
 260 restrict -6 default kod nomodify notrap nopeer noquery
 261
 262 # Yet, allow use of the local 'ntpq'.
 263 restrict 127.0.0.1
 264 restrict -6 ::1\n"))
 265
 266        (define ntpd.conf
 267          (plain-file "ntpd.conf" config))
 268
 269        (list (dmd-service
 270               (provision '(ntpd))
 271               (documentation "Run the Network Time Protocol (NTP) daemon.")
 272               (requirement '(user-processes networking))
 273               (start #~(make-forkexec-constructor
 274                         (list (string-append #$ntp "/bin/ntpd") "-n"
 275                               "-c" #$ntpd.conf "-u" "ntpd")))
 276               (stop #~(make-kill-destructor))))))))
 277
 278 (define %ntp-accounts
 279   (list (user-account
 280          (name "ntpd")
 281          (group "nogroup")
 282          (system? #t)
 283          (comment "NTP daemon user")
 284          (home-directory "/var/empty")
 285          (shell #~(string-append #$shadow "/sbin/nologin")))))
 286
 287 (define ntp-service-type
 288   (service-type (name 'ntp)
 289                 (extensions
 290                  (list (service-extension dmd-root-service-type
 291                                           ntp-dmd-service)
 292                        (service-extension account-service-type
 293                                           (const %ntp-accounts))))))
 294
 295 (define* (ntp-service #:key (ntp ntp)
 296                       (servers %ntp-servers))
 297   "Return a service that runs the daemon from @var{ntp}, the
 298 @uref{http://www.ntp.org, Network Time Protocol package}.  The daemon will
 299 keep the system clock synchronized with that of @var{servers}."
 300   (service ntp-service-type
 301            (ntp-configuration (ntp ntp) (servers servers))))
 302
 303 \f
 304 ;;;
 305 ;;; Tor.
 306 ;;;
 307
 308 (define %tor-accounts
 309   ;; User account and groups for Tor.
 310   (list (user-group (name "tor") (system? #t))
 311         (user-account
 312          (name "tor")
 313          (group "tor")
 314          (system? #t)
 315          (comment "Tor daemon user")
 316          (home-directory "/var/empty")
 317          (shell #~(string-append #$shadow "/sbin/nologin")))))
 318
 319 (define (tor-dmd-service tor)
 320   "Return a <dmd-service> running TOR."
 321   (let ((torrc (plain-file "torrc" "User tor\n")))
 322     (list (dmd-service
 323            (provision '(tor))
 324
 325            ;; Tor needs at least one network interface to be up, hence the
 326            ;; dependency on 'loopback'.
 327            (requirement '(user-processes loopback))
 328
 329            (start #~(make-forkexec-constructor
 330                      (list (string-append #$tor "/bin/tor") "-f" #$torrc)))
 331            (stop #~(make-kill-destructor))
 332            (documentation "Run the Tor anonymous network overlay.")))))
 333
 334 (define tor-service-type
 335   (service-type (name 'tor)
 336                 (extensions
 337                  (list (service-extension dmd-root-service-type
 338                                           tor-dmd-service)
 339                        (service-extension account-service-type
 340                                           (const %tor-accounts))))))
 341
 342 (define* (tor-service #:key (tor tor))
 343   "Return a service to run the @uref{https://torproject.org,Tor} daemon.
 344
 345 The daemon runs with the default settings (in particular the default exit
 346 policy) as the @code{tor} unprivileged user."
 347   (service tor-service-type tor))
 348
 349 \f
 350 ;;;
 351 ;;; BitlBee.
 352 ;;;
 353
 354 (define-record-type* <bitlbee-configuration>
 355   bitlbee-configuration make-bitlbee-configuration
 356   bitlbee-configuration?
 357   (bitlbee bitlbee-configuration-bitlbee
 358            (default bitlbee))
 359   (interface bitlbee-configuration-interface)
 360   (port bitlbee-configuration-port)
 361   (extra-settings bitlbee-configuration-extra-settings))
 362
 363 (define bitlbee-dmd-service
 364   (match-lambda
 365     (($ <bitlbee-configuration> bitlbee interface port extra-settings)
 366      (let ((conf (plain-file "bitlbee.conf"
 367                              (string-append "
 368   [settings]
 369   User = bitlbee
 370   ConfigDir = /var/lib/bitlbee
 371   DaemonInterface = " interface "
 372   DaemonPort = " (number->string port) "
 373 " extra-settings))))
 374
 375        (list (dmd-service
 376               (provision '(bitlbee))
 377               (requirement '(user-processes loopback))
 378               (start #~(make-forkexec-constructor
 379                         (list (string-append #$bitlbee "/sbin/bitlbee")
 380                               "-n" "-F" "-u" "bitlbee" "-c" #$conf)))
 381               (stop  #~(make-kill-destructor))))))))
 382
 383 (define %bitlbee-accounts
 384   ;; User group and account to run BitlBee.
 385   (list (user-group (name "bitlbee") (system? #t))
 386         (user-account
 387          (name "bitlbee")
 388          (group "bitlbee")
 389          (system? #t)
 390          (comment "BitlBee daemon user")
 391          (home-directory "/var/empty")
 392          (shell #~(string-append #$shadow "/sbin/nologin")))))
 393
 394 (define %bitlbee-activation
 395   ;; Activation gexp for BitlBee.
 396   #~(begin
 397       (use-modules (guix build utils))
 398
 399       ;; This directory is used to store OTR data.
 400       (mkdir-p "/var/lib/bitlbee")
 401       (let ((user (getpwnam "bitlbee")))
 402         (chown "/var/lib/bitlbee"
 403                (passwd:uid user) (passwd:gid user)))))
 404
 405 (define bitlbee-service-type
 406   (service-type (name 'bitlbee)
 407                 (extensions
 408                  (list (service-extension dmd-root-service-type
 409                                           bitlbee-dmd-service)
 410                        (service-extension account-service-type
 411                                           (const %bitlbee-accounts))
 412                        (service-extension activation-service-type
 413                                           (const %bitlbee-activation))))))
 414
 415 (define* (bitlbee-service #:key (bitlbee bitlbee)
 416                           (interface "127.0.0.1") (port 6667)
 417                           (extra-settings ""))
 418   "Return a service that runs @url{http://bitlbee.org,BitlBee}, a daemon that
 419 acts as a gateway between IRC and chat networks.
 420
 421 The daemon will listen to the interface corresponding to the IP address
 422 specified in @var{interface}, on @var{port}.  @code{127.0.0.1} means that only
 423 local clients can connect, whereas @code{0.0.0.0} means that connections can
 424 come from any networking interface.
 425
 426 In addition, @var{extra-settings} specifies a string to append to the
 427 configuration file."
 428   (service bitlbee-service-type
 429            (bitlbee-configuration
 430             (bitlbee bitlbee)
 431             (interface interface) (port port)
 432             (extra-settings extra-settings))))
 433
 434 \f
 435 ;;;
 436 ;;; Wicd.
 437 ;;;
 438
 439 (define %wicd-activation
 440   ;; Activation gexp for Wicd.
 441   #~(begin
 442       (use-modules (guix build utils))
 443
 444       (mkdir-p "/etc/wicd")
 445       (let ((file-name "/etc/wicd/dhclient.conf.template.default"))
 446         (unless (file-exists? file-name)
 447           (copy-file (string-append #$wicd file-name)
 448                      file-name)))))
 449
 450 (define (wicd-dmd-service wicd)
 451   "Return a dmd service for WICD."
 452   (list (dmd-service
 453          (documentation "Run the Wicd network manager.")
 454          (provision '(networking))
 455          (requirement '(user-processes dbus-system loopback))
 456          (start #~(make-forkexec-constructor
 457                    (list (string-append #$wicd "/sbin/wicd")
 458                          "--no-daemon")))
 459          (stop #~(make-kill-destructor)))))
 460
 461 (define wicd-service-type
 462   (service-type (name 'wicd)
 463                 (extensions
 464                  (list (service-extension dmd-root-service-type
 465                                           wicd-dmd-service)
 466                        (service-extension dbus-root-service-type
 467                                           list)
 468                        (service-extension activation-service-type
 469                                           (const %wicd-activation))))))
 470
 471 (define* (wicd-service #:key (wicd wicd))
 472   "Return a service that runs @url{https://launchpad.net/wicd,Wicd}, a network
 473 manager that aims to simplify wired and wireless networking."
 474   (service wicd-service-type wicd))
 475
 476 ;;; networking.scm ends here