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 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (gnu installer services)
  22   #:use-module (guix records)
  23   #:use-module (srfi srfi-1)
  24   #:export (system-service?
  25             system-service-name
  26             system-service-type
  27             system-service-recommended?
  28             system-service-snippet
  29             system-service-packages
  30
  31             desktop-system-service?
  32             networking-system-service?
  33
  34             %system-services
  35             system-services->configuration))
  36
  37 (define-record-type* <system-service>
  38   system-service make-system-service
  39   system-service?
  40   (name            system-service-name)           ;string
  41   (type            system-service-type)           ;'desktop | 'networking
  42   (recommended?    system-service-recommended?    ;Boolean
  43                    (default #f))
  44   (snippet         system-service-snippet         ;list of sexps
  45                    (default '()))
  46   (packages        system-service-packages        ;list of sexps
  47                    (default '())))
  48
  49 ;; This is the list of desktop environments supported as services.
  50 (define %system-services
  51   (let-syntax ((desktop-environment (syntax-rules ()
  52                                       ((_ fields ...)
  53                                        (system-service
  54                                         (type 'desktop)
  55                                         fields ...))))
  56                (G_ (syntax-rules ()               ;for xgettext
  57                      ((_ str) str))))
  58     (list
  59      (desktop-environment
  60       (name "GNOME")
  61       (snippet '((service gnome-desktop-service-type))))
  62      (desktop-environment
  63       (name "Xfce")
  64       (snippet '((service xfce-desktop-service-type))))
  65      (desktop-environment
  66       (name "MATE")
  67       (snippet '((service mate-desktop-service-type))))
  68      (desktop-environment
  69       (name "Enlightenment")
  70       (snippet '((service enlightenment-desktop-service-type))))
  71      (desktop-environment
  72       (name "Openbox")
  73       (packages '((specification->package "openbox"))))
  74      (desktop-environment
  75       (name "awesome")
  76       (packages '((specification->package "awesome"))))
  77      (desktop-environment
  78       (name "i3")
  79       (packages (map (lambda (package)
  80                        `(specification->package ,package))
  81                      '("i3-wm" "i3status" "dmenu" "st"))))
  82      (desktop-environment
  83       (name "ratpoison")
  84       (packages '((specification->package "ratpoison")
  85                   (specification->package "xterm"))))
  86      (desktop-environment
  87       (name "Emacs EXWM")
  88       (packages '((specification->package "emacs")
  89                   (specification->package "emacs-exwm")
  90                   (specification->package "emacs-desktop-environment"))))
  91
  92      ;; Networking.
  93      (system-service
  94       (name (G_ "OpenSSH secure shell daemon (sshd)"))
  95       (type 'networking)
  96       (snippet '((service openssh-service-type))))
  97      (system-service
  98       (name (G_ "Tor anonymous network router"))
  99       (type 'networking)
 100       (snippet '((service tor-service-type))))
 101      (system-service
 102       (name (G_ "Mozilla NSS certificates, for HTTPS access"))
 103       (type 'networking)
 104       (packages '((specification->package "nss-certs")))
 105       (recommended? #t))
 106
 107      ;; Network connectivity management.
 108      (system-service
 109       (name (G_ "NetworkManager network connection manager"))
 110       (type 'network-management)
 111       (snippet '((service network-manager-service-type)
 112                  (service wpa-supplicant-service-type))))
 113      (system-service
 114       (name (G_ "Connman network connection manager"))
 115       (type 'network-management)
 116       (snippet '((service connman-service-type)
 117                  (service wpa-supplicant-service-type))))
 118      (system-service
 119       (name (G_ "DHCP client (dynamic IP address assignment)"))
 120       (type 'network-management)
 121       (snippet '((service dhcp-client-service-type)))))))
 122
 123 (define (desktop-system-service? service)
 124   "Return true if SERVICE is a desktop environment service."
 125   (eq? 'desktop (system-service-type service)))
 126
 127 (define (networking-system-service? service)
 128   "Return true if SERVICE is a desktop environment service."
 129   (eq? 'networking (system-service-type service)))
 130
 131 (define (system-services->configuration services)
 132   "Return the configuration field for SERVICES."
 133   (let* ((snippets (append-map system-service-snippet services))
 134          (packages (append-map system-service-packages services))
 135          (desktop? (find desktop-system-service? services))
 136          (base     (if desktop?
 137                        '%desktop-services
 138                        '%base-services)))
 139     (if (null? snippets)
 140         `(,@(if (null? packages)
 141                 '()
 142                 `((packages (append (list ,@packages)
 143                                     %base-packages))))
 144           (services ,base))
 145         `(,@(if (null? packages)
 146                 '()
 147                 `((packages (append (list ,@packages)
 148                                     %base-packages))))
 149           (services (append (list ,@snippets
 150
 151                                   ,@(if desktop?
 152                                         ;; XXX: Assume 'keyboard-layout' is in
 153                                         ;; scope.
 154                                         '((set-xorg-configuration
 155                                            (xorg-configuration
 156                                             (keyboard-layout keyboard-layout))))
 157                                         '()))
 158                            ,base))))))