;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;;
;;; 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 <http://www.gnu.org/licenses/>.

(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>
  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
     (($ <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
                                    (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>
  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
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 <dmd-service> 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>
  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)
                          (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))))))

(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 wicd-service-type wicd))

;;; networking.scm ends here