gnu/installer/services.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
   3 ;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.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 installer services)
  21   #:use-module (guix records)
  22   #:use-module (srfi srfi-1)
  23   #:export (system-service?
  24             system-service-name
  25             system-service-type
  26             system-service-recommended?
  27             system-service-snippet
  28             system-service-packages
  29
  30             desktop-system-service?
  31             networking-system-service?
  32
  33             %system-services
  34             system-services->configuration))
  35
  36 (define-record-type* <system-service>
  37   system-service make-system-service
  38   system-service?
  39   (name            system-service-name)           ;string
  40   (type            system-service-type)           ;'desktop | 'networking
  41   (recommended?    system-service-recommended?    ;Boolean
  42                    (default #f))
  43   (snippet         system-service-snippet         ;list of sexps
  44                    (default '()))
  45   (packages        system-service-packages        ;list of sexps
  46                    (default '())))
  47
  48 ;; This is the list of desktop environments supported as services.
  49 (define %system-services
  50   (let-syntax ((desktop-environment (syntax-rules ()
  51                                       ((_ fields ...)
  52                                        (system-service
  53                                         (type 'desktop)
  54                                         fields ...))))
  55                (G_ (syntax-rules ()               ;for xgettext
  56                      ((_ str) str))))
  57     (list
  58      (desktop-environment
  59       (name "GNOME")
  60       (snippet '((service gnome-desktop-service-type))))
  61      (desktop-environment
  62       (name "Xfce")
  63       (snippet '((service xfce-desktop-service-type))))
  64      (desktop-environment
  65       (name "MATE")
  66       (snippet '((service mate-desktop-service-type))))
  67      (desktop-environment
  68       (name "Enlightenment")
  69       (snippet '((service enlightenment-desktop-service-type))))
  70      (desktop-environment
  71       (name "Openbox")
  72       (packages '((specification->package "openbox"))))
  73      (desktop-environment
  74       (name "awesome")
  75       (packages '((specification->package "awesome"))))
  76      (desktop-environment
  77       (name "i3")
  78       (packages (map (lambda (package)
  79                        `(specification->package ,package))
  80                      '("i3-wm" "i3status" "dmenu" "st"))))
  81      (desktop-environment
  82       (name "ratpoison")
  83       (packages '((specification->package "ratpoison")
  84                   (specification->package "xterm"))))
  85
  86      ;; Networking.
  87      (system-service
  88       (name (G_ "OpenSSH secure shell daemon (sshd)"))
  89       (type 'networking)
  90       (snippet '((service openssh-service-type))))
  91      (system-service
  92       (name (G_ "Tor anonymous network router"))
  93       (type 'networking)
  94       (snippet '((service tor-service-type))))
  95      (system-service
  96       (name (G_ "Mozilla NSS certificates, for HTTPS access"))
  97       (type 'networking)
  98       (packages '((specification->package "nss-certs")))
  99       (recommended? #t))
 100
 101      ;; Network connectivity management.
 102      (system-service
 103       (name (G_ "NetworkManager network connection manager"))
 104       (type 'network-management)
 105       (snippet '((service network-manager-service-type)
 106                  (service wpa-supplicant-service-type))))
 107      (system-service
 108       (name (G_ "Connman network connection manager"))
 109       (type 'network-management)
 110       (snippet '((service connman-service-type)
 111                  (service wpa-supplicant-service-type))))
 112      (system-service
 113       (name (G_ "DHCP client (dynamic IP address assignment)"))
 114       (type 'network-management)
 115       (snippet '((service dhcp-client-service-type)))))))
 116
 117 (define (desktop-system-service? service)
 118   "Return true if SERVICE is a desktop environment service."
 119   (eq? 'desktop (system-service-type service)))
 120
 121 (define (networking-system-service? service)
 122   "Return true if SERVICE is a desktop environment service."
 123   (eq? 'networking (system-service-type service)))
 124
 125 (define (system-services->configuration services)
 126   "Return the configuration field for SERVICES."
 127   (let* ((snippets (append-map system-service-snippet services))
 128          (packages (append-map system-service-packages services))
 129          (desktop? (find desktop-system-service? services))
 130          (base     (if desktop?
 131                        '%desktop-services
 132                        '%base-services)))
 133     (if (null? snippets)
 134         `(,@(if (null? packages)
 135                 '()
 136                 `((packages (append (list ,@packages)
 137                                     %base-packages))))
 138           (services ,base))
 139         `(,@(if (null? packages)
 140                 '()
 141                 `((packages (append (list ,@packages)
 142                                     %base-packages))))
 143           (services (append (list ,@snippets
 144
 145                                   ,@(if desktop?
 146                                         ;; XXX: Assume 'keyboard-layout' is in
 147                                         ;; scope.
 148                                         '((set-xorg-configuration
 149                                            (xorg-configuration
 150                                             (keyboard-layout keyboard-layout))))
 151                                         '()))
 152                            ,base))))))