;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2018 Clément Lassieur ;;; Copyright © 2017 Mathieu Othacehe ;;; Copyright © 2015, 2017-2020, 2022-2024 Ludovic Courtès ;;; Copyright © 2018 Pierre-Antoine Rouby ;;; ;;; 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 . (define-module (gnu services messaging) #:use-module (gnu packages admin) #:use-module (gnu packages base) #:use-module (gnu packages irc) #:use-module (gnu packages messaging) #:use-module (gnu packages tls) #:use-module (gnu services) #:use-module (gnu services shepherd) #:use-module (gnu services configuration) #:use-module (gnu system shadow) #:autoload (gnu build linux-container) (%namespaces) #:use-module ((gnu system file-systems) #:select (file-system-mapping)) #:use-module (guix gexp) #:use-module (guix modules) #:use-module (guix records) #:use-module (guix packages) #:use-module (guix deprecation) #:use-module (guix least-authority) #:use-module (srfi srfi-1) #:use-module (srfi srfi-35) #:use-module (ice-9 match) #:export (prosody-service-type prosody-configuration opaque-prosody-configuration virtualhost-configuration int-component-
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2016-2017, 2019-2023 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2020 Google LLC
;;; Copyright © 2022 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2023 Pierre Langlois <pierre.langlois@gmx.com>
;;; Copyright © 2024 Leo Nikkilä <hello@lnikki.la>
;;;
;;; 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 system linux-container)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (guix config)
  #:use-module (guix store)
  #:use-module (guix gexp)
  #:use-module (guix derivations)
  #:use-module (guix monads)
  #:use-module (guix modules)
  #:use-module (gnu build linux-container)
  #:use-module (gnu services)
  #:use-module (gnu services base)
  #:use-module (gnu services networking)
  #:use-module (gnu services shepherd)
  #:use-module (gnu system)
  #:use-module (gnu system file-systems)
  #:export (system-container
            containerized-operating-system
            container-script
            eval/container))

(define* (container-essential-services os #:key shared-network?)
  "Return a list of essential services corresponding to OS, a
non-containerized OS.  This procedure essentially strips essential services
from OS that are needed on the bare metal and not in a container."
  (define base
    (remove (lambda (service)
              (memq (service-kind service)
                    (cons* (service-kind %linux-bare-metal-service)
                           firmware-service-type
                           system-service-type
                           (if shared-network?
                               (list hosts-service-type)
                               '()))))
            (operating-system-essential-services os)))

  (cons (service system-service-type
                 `(("locale" ,(operating-system-locale-directory os))))
        ;; If network is to be shared with the host, remove network
        ;; configuration files from etc-service.
        (if shared-network?
            (modify-services base
              (etc-service-type
               files => (remove
                         (match-lambda
                           ((filename _)
                            (member filename
                                    (map basename %network-configuration-files))))
                         files)))
            base)))

(define dummy-networking-service-type
  (shepherd-service-type
   'dummy-networking
   (const (shepherd-service
           (documentation "Provide loopback and networking without actually
doing anything.")
           (provision '(loopback networking))
           (start #~(const #t))))
   #f
   (description "Provide loopback and networking without actually doing
anything.  This service is used by guest systems running in containers, where
networking support is provided by the host.")))

(define %nscd-container-caches
  ;; Similar to %nscd-default-caches but with smaller cache sizes. This allows
  ;; many containers to coexist on the same machine without exhausting RAM.
  (map (lambda (cache)
         (nscd-cache
          (inherit cache)
          (max-database-size (expt 2 18)))) ;256KiB
       %nscd-default-caches))

(define* (containerized-operating-system os mappings
                                         #:key
                                         shared-network?
                                         (extra-file-systems '()))
  "Return an operating system based on OS for use in a Linux container
environment.  MAPPINGS is a list of <file-system-mapping> to realize in the
containerized OS.  EXTRA-FILE-SYSTEMS is a list of file systems to add to OS."
  (define user-file-systems
    (remove (lambda (fs)
              (let ((target (file-system-mount-point fs))
                    (source (file-system-device fs)))
                (or (string=? target (%store-prefix))
                    (string=? target "/")
                    (and (string? source)
                         (string-prefix? "/dev/" source))
                    (string-prefix? "/dev/" target)
                    (string-prefix? "/sys/" target))))
            (operating-system-file-systems os)))

  (define (mapping->fs fs)
    (file-system (inherit (file-system-mapping->bind-mount fs))
      (needed-for-boot? #t)))

  (define services-to-drop
    ;; Service types to filter from the original operating-system. Some of
    ;; these make no sense in a container (e.g., those that access
    ;; /dev/tty[0-9]), while others just need to be reinstantiated with
    ;; different configs that are better suited to containers.
    (append (list console-font-service-type
                  mingetty-service-type
                  agetty-service-type)
            (if shared-network?
                ;; Replace these with dummy-networking-service-type below.
                (list
                 static-networking-service-type
                 dhcp-client-service-type
                 network-manager-service-type
                 connman-service-type)
                (list))))

  (define services-to-add
    ;; Many Guix services depend on a 'networking' shepherd
    ;; service, so make sure to provide a dummy 'networking'
    ;; service when we are sure that networking is already set up
    ;; in the host and can be used.  That prevents double setup.
    (if shared-network?
        (list (service dummy-networking-service-type))
        '()))

  (define os-with-base-essential-services
    (operating-system
      (inherit os)
      (swap-devices '()) ; disable swap
      (services
       (append services-to-add
               (filter-map (lambda (s)
                             (cond ((memq (service-kind s) services-to-drop)
                                    #f)
                                   ((eq? nscd-service-type (service-kind s))
                                    (service nscd-service-type
                                             (nscd-configuration
                                              (inherit (service-value s))
                                              (caches %nscd-container-caches))))
                                   ((eq? guix-service-type (service-kind s))
                                    ;; Pass '--disable-chroot' so that
                                    ;; guix-daemon can build thing even in
                                    ;; Docker without '--privileged'.
                                    (service guix-service-type
                                             (guix-configuration
                                              (inherit (service-value s))
                                              (extra-options
                                               (cons "--disable-chroot"
                                                     (guix-configuration-extra-options
                                                      (service-value s)))))))
                                   (else s)))
                           (operating-system-user-services os))))
      (file-systems (append (map mapping->fs
                                 (if shared-network?
                                     (append %network-file-mappings mappings)
                                     mappings))
                            extra-file-systems
                            user-file-systems

                            ;; Provide a dummy root file system so we can create
                            ;; a 'boot-parameters' file.
                            (list (file-system
                                    (mount-point "/")
                                    (device "nothing")
                                    (type "dummy")))))))

  ;; `essential-services' is thunked, we need to evaluate it separately.
  (operating-system
    (inherit os-with-base-essential-services)
    (essential-services (container-essential-services
                         os-with-base-essential-services
                         #:shared-network? shared-network?))))

(define* (container-script os #:key (mappings '()) shared-network?)
  "Return a derivation of a script that runs OS as a Linux container.
MAPPINGS is a list of <file-system> objects that specify the files/directories
that will be shared with the host system."
  (define (mountable-file-system? file-system)
    ;; Return #t if FILE-SYSTEM should be mounted in the container.
    (and (not (string=? "/" (file-system-mount-point file-system)))
         (file-system-needed-for-boot? file-system)))

  (define (os-file-system-specs os)
    (map file-system->spec
         (filter mountable-file-system?
                 (operating-system-file-systems os))))

  (let* ((os (containerized-operating-system
              os (cons %store-mapping mappings)
              #:shared-network? shared-network?
              #:extra-file-systems %container-file-systems))
         (specs (os-file-system-specs os)))

    (define script
      (with-imported-modules (source-module-closure
                              '((guix build utils)
                                (gnu build linux-container)
                                (guix i18n)
                                (guix diagnostics)))
        #~(begin
            (use-modules (gnu build linux-container)
                         (gnu system file-systems) ;spec->file-system
                         (guix build utils)
                         (guix i18n)
                         (guix diagnostics)
                         (srfi srfi-1)
                         (srfi srfi-37)
                         (ice-9 match))

            (define (show-help)
              (display (G_ "Usage: run-container [OPTION ...]
Run the container with the given options."))
              (newline)
              (display (G_ "
      --share=SPEC       share host file system with read/write access
                         according to SPEC"))
              (display (G_ "
      --expose=SPEC      expose host file system directory as read-only
                         according to SPEC"))
              (newline)
              (display (G_ "
  -h, --help             display this help and exit"))
              (newline))

            (define %options
              ;; Specifications of the command-line options.
              (list (option '(#\h "help") #f #f
                            (lambda args
                              (show-help)
                              (exit 0)))
                    (option '("share") #t #f
                            (lambda (opt name arg result)
                              (alist-cons 'file-system-mapping
                                          (specification->file-system-mapping arg #t)
                                          result)))
                    (option '("expose") #t #f
                            (lambda (opt name arg result)
                              (alist-cons 'file-system-mapping
                                          (specification->file-system-mapping arg #f)
                                          result)))))

            (define (parse-options args options)
              (args-fold args options
                         (lambda (opt name arg . rest)
                           (report-error (G_ "~A: unrecognized option~%") name)
                           (exit 1))
                         (lambda (op res) (cons op res))
                         '()))

            (define (explain pid)
              ;; XXX: We can't quite call 'bindtextdomain' so there's actually
              ;; no i18n.
              ;; XXX: Should we really give both options? 'guix container exec'
              ;; is a more verbose command.  Hard to fail to enter the container
              ;; when we list two options.
              (info (G_ "system container is running as PID ~a~%") pid)
              (info (G_ "Run 'sudo guix container exec ~a /run/current-system/profile/bin/bash --login'\n")
                    pid)
              (info (G_ "or run 'sudo nsenter -a -t ~a' to get a shell into it.~%") pid)
              (newline (guix-warning-port)))

            (let* ((opts (parse-options (cdr (command-line)) %options))
                   (mappings (filter-map (match-lambda
                                           (('file-system-mapping . mapping) mapping)
                                           (_ #f))
                                         opts))
                   (file-systems
                    (filter-map (lambda (fs)
                                  (let ((flags (file-system-flags fs)))
                                    (and (or (not (memq 'bind-mount flags))
                                             (file-exists? (file-system-device fs)))
                                         fs)))
                                (append (map file-system-mapping->bind-mount mappings)
                                        (map spec->file-system '#$specs)))))
              (call-with-container file-systems
                (lambda ()
                  (setenv "HOME" "/root")
                  (setenv "TMPDIR" "/tmp")
                  (setenv "GUIX_NEW_SYSTEM" #$os)
                  (for-each mkdir-p '("/run" "/bin" "/etc" "/home" "/var"))
                  (primitive-load (string-append #$os "/boot")))
                ;; A range of 65536 uid/gids is used to cover 16 bits worth of
                ;; users and groups, which is sufficient for most cases.
                ;;
                ;; See: http://www.freedesktop.org/software/systemd/man/systemd-nspawn.html#--private-users=
                #:host-uids 65536
                #:namespaces (if #$shared-network?
                                 (delq 'net %namespaces)
                                 %namespaces)
                #:process-spawned-hook explain)))))

    (gexp->script "run-container" script)))

(define* (eval/container exp
                         #:key
                         (mappings '())
                         (namespaces %namespaces)
                         (guest-uid 0) (guest-gid 0))
  "Evaluate EXP, a gexp, in a new process executing in separate namespaces as
listed in NAMESPACES.  Add MAPPINGS, a list of <file-system-mapping>, to the
set of directories visible in the process's mount namespace.  Inside the
namespaces, run code as GUEST-UID and GUEST-GID.  Return the process' exit
status as a monadic value.

This is useful to implement processes that, unlike derivations, are not
entirely pure and need to access the outside world or to perform side
effects."
  (mlet %store-monad ((lowered (lower-gexp exp)))
    (define inputs
      (cons (lowered-gexp-guile lowered)
            (lowered-gexp-inputs lowered)))

    (define items
      (append (append-map derivation-input-output-paths inputs)
              (lowered-gexp-sources lowered)))

    (mbegin %store-monad
      (built-derivations inputs)
      (mlet %store-monad ((closure ((store-lift requisites) items)))
        (return (call-with-container (map file-system-mapping->bind-mount
                                          (append (map (lambda (item)
                                                         (file-system-mapping
                                                          (source item)
                                                          (target source)))
                                                       closure)
                                                  mappings))
                  (lambda ()
                    (apply execl
                           (string-append (derivation-input-output-path
                                           (lowered-gexp-guile lowered))
                                          "/bin/guile")
                           "guile"
                           (append (append-map (lambda (directory)
                                                 `("-L" ,directory))
                                               (lowered-gexp-load-path lowered))
                                   (append-map (lambda (directory)
                                                 `("-C" ,directory))
                                               (lowered-gexp-load-compiled-path
                                                lowered))
                                   (list "-c"
                                         (object->string
                                          (lowered-gexp-sexp lowered))))))
                  #:namespaces namespaces
                  #:guest-uid guest-uid
                  #:guest-gid guest-gid))))))
generated by cgit
(string (configuration-missing-field 'int-component 'hostname)) "Hostname of the component." int-component) (plugin (string (configuration-missing-field 'int-component 'plugin)) "Plugin you wish to use for the component." int-component) (mod-muc (maybe-mod-muc-configuration %unset-value) "Multi-user chat (MUC) is Prosody's module for allowing you to create hosted chatrooms/conferences for XMPP users. General information on setting up and using multi-user chatrooms can be found in the \"Chatrooms\" documentation (@url{https://prosody.im/doc/chatrooms}), which you should read if you are new to XMPP chatrooms. See also @url{https://prosody.im/doc/modules/mod_muc}." int-component) (hostname (string (configuration-missing-field 'ext-component 'hostname)) "Hostname of the component." ext-component) (raw-content (maybe-raw-content %unset-value) "Raw content that will be added to the configuration file." common))) ;; Serialize Virtualhost line first. (define (serialize-virtualhost-configuration config) (define (rest? field) (not (memq (configuration-field-name field) '(domain)))) (let ((domain (virtualhost-configuration-domain config)) (rest (filter rest? virtualhost-configuration-fields))) #~(string-append #$(format #f "VirtualHost \"~a\"\n" domain) #$(serialize-configuration config rest)))) ;; Serialize Component line first. (define (serialize-int-component-configuration config) (define (rest? field) (not (memq (configuration-field-name field) '(hostname plugin)))) (let ((hostname (int-component-configuration-hostname config)) (plugin (int-component-configuration-plugin config)) (rest (filter rest? int-component-configuration-fields))) #~(string-append #$(format #f "Component \"~a\" \"~a\"\n" hostname plugin) #$(serialize-configuration config rest)))) ;; Serialize Component line first. (define (serialize-ext-component-configuration config) (define (rest? field) (not (memq (configuration-field-name field) '(hostname)))) (let ((hostname (ext-component-configuration-hostname config)) (rest (filter rest? ext-component-configuration-fields))) #~(string-append #$(format #f "Component \"~a\"\n" hostname) #$(serialize-configuration config rest)))) ;; Serialize virtualhosts and components last. (define (serialize-prosody-configuration config) (define (rest? field) (not (memq (configuration-field-name field) '(virtualhosts int-components ext-components)))) #~(string-append #$(let ((rest (filter rest? prosody-configuration-fields))) (serialize-configuration config rest)) #$(serialize-virtualhost-configuration-list (prosody-configuration-virtualhosts config)) #$(serialize-int-component-configuration-list (prosody-configuration-int-components config)) #$(serialize-ext-component-configuration-list (prosody-configuration-ext-components config)))) (define-configuration opaque-prosody-configuration (prosody (file-like prosody) "The prosody package.") (prosody.cfg.lua (string (configuration-missing-field 'opaque-prosody-configuration 'prosody.cfg.lua)) "The contents of the @code{prosody.cfg.lua} to use.")) (define (prosody-shepherd-service config) "Return a for Prosody with CONFIG." (let* ((prosody (if (opaque-prosody-configuration? config) (opaque-prosody-configuration-prosody config) (prosody-configuration-prosody config))) (prosodyctl-bin (file-append prosody "/bin/prosodyctl")) (pid-file (prosody-configuration-pidfile config)) (prosodyctl-action (lambda args #~(lambda _ (invoke #$prosodyctl-bin #$@args) (match '#$args (("start") (call-with-input-file #$pid-file read)) (_ #t)))))) (list (shepherd-service (documentation "Run the Prosody XMPP server") (provision '(prosody xmpp-daemon)) (requirement '(networking syslogd user-processes)) (modules `((ice-9 match) ,@%default-modules)) (start (prosodyctl-action "start")) (stop (prosodyctl-action "stop")))))) (define %prosody-accounts (list (user-group (name "prosody") (system? #t)) (user-account (name "prosody") (group "prosody") (system? #t) (comment "Prosody daemon user") (home-directory "/var/empty") (shell (file-append shadow "/sbin/nologin"))))) (define (prosody-activation config) "Return the activation gexp for CONFIG." (let* ((config-dir "/etc/prosody") (default-certs-dir "/etc/prosody/certs") (data-path (prosody-configuration-data-path config)) (pidfile-dir (dirname (prosody-configuration-pidfile config))) (config-str (if (opaque-prosody-configuration? config) (opaque-prosody-configuration-prosody.cfg.lua config) #~(begin (use-modules (ice-9 format)) #$(serialize-prosody-configuration config)))) (config-file (mixed-text-file "prosody.cfg.lua" config-str))) #~(begin (use-modules (guix build utils)) (define %user (getpw "prosody")) (mkdir-p #$config-dir) (chown #$config-dir (passwd:uid %user) (passwd:gid %user)) (copy-file #$config-file (string-append #$config-dir "/prosody.cfg.lua")) (mkdir-p #$default-certs-dir) (chown #$default-certs-dir (passwd:uid %user) (passwd:gid %user)) (chmod #$default-certs-dir #o750) (mkdir-p #$data-path) (chown #$data-path (passwd:uid %user) (passwd:gid %user)) (chmod #$data-path #o750) (mkdir-p #$pidfile-dir) (chown #$pidfile-dir (passwd:uid %user) (passwd:gid %user))))) (define prosody-service-type (service-type (name 'prosody) (extensions (list (service-extension shepherd-root-service-type prosody-shepherd-service) (service-extension account-service-type (const %prosody-accounts)) (service-extension activation-service-type prosody-activation))) (default-value (prosody-configuration (virtualhosts (list (virtualhost-configuration (domain "localhost")))))) (description "Run Prosody, a modern XMPP communication server."))) ;; A little helper to make it easier to document all those fields. (define (generate-documentation) (define documentation `((prosody-configuration ,prosody-configuration-fields (ssl ssl-configuration) (virtualhosts virtualhost-configuration) (int-components int-component-configuration) (ext-components ext-component-configuration)) (ssl-configuration ,ssl-configuration-fields) (int-component-configuration ,int-component-configuration-fields (mod-muc mod-muc-configuration)) (ext-component-configuration ,ext-component-configuration-fields) (mod-muc-configuration ,mod-muc-configuration-fields) (virtualhost-configuration ,virtualhost-configuration-fields) (opaque-prosody-configuration ,opaque-prosody-configuration-fields))) (define (generate configuration-name) (match (assq-ref documentation configuration-name) ((fields . sub-documentation) (format #t "\nAvailable @code{~a} fields are:\n\n" configuration-name) (when (memq configuration-name '(virtualhost-configuration int-component-configuration ext-component-configuration)) (format #t "all these @code{prosody-configuration} fields: ~a, plus:\n" (string-join (map (lambda (s) (format #f "@code{~a}" s)) common-fields) ", "))) (for-each (lambda (f) (let ((field-name (configuration-field-name f)) (field-type (configuration-field-type f)) (field-docs (string-trim-both (configuration-field-documentation f))) (default (catch #t (configuration-field-default-value-thunk f) (lambda _ 'nope)))) (define (escape-chars str chars escape) (with-output-to-string (lambda () (string-for-each (lambda (c) (when (char-set-contains? chars c) (display escape)) (display c)) str)))) (define (show-default? val) (or (string? val) (number? val) (boolean? val) (and (list? val) (and-map show-default? val)))) (format #t "@deftypevr {@code{~a} parameter} ~a ~a\n~a\n" configuration-name field-type field-name field-docs) (when (show-default? default) (format #t "Defaults to @samp{~a}.\n" (escape-chars (format #f "~s" default) (char-set #\@ #\{ #\}) #\@))) (for-each generate (or (assq-ref sub-documentation field-name) '())) (format #t "@end deftypevr\n\n"))) (filter (lambda (f) (not (string=? "" (configuration-field-documentation f)))) fields))))) (generate 'prosody-configuration) (format #t "It could be that you just want to get a @code{prosody.cfg.lua} up and running. In that case, you can pass an @code{opaque-prosody-configuration} record as the value of @code{prosody-service-type}. As its name indicates, an opaque configuration does not have easy reflective capabilities.") (generate 'opaque-prosody-configuration) (format #t "For example, if your @code{prosody.cfg.lua} is just the empty string, you could instantiate a prosody service like this: @example (service prosody-service-type (opaque-prosody-configuration (prosody.cfg.lua \"\"))) @end example")) ;;; ;;; BitlBee. ;;; (define-record-type* bitlbee-configuration make-bitlbee-configuration bitlbee-configuration? (bitlbee bitlbee-configuration-bitlbee (default bitlbee)) (interface bitlbee-configuration-interface (default "127.0.0.1")) (port bitlbee-configuration-port (default 6667)) (plugins bitlbee-plugins (default '())) (extra-settings bitlbee-configuration-extra-settings (default ""))) (define bitlbee-shepherd-service (match-lambda (($ bitlbee interface port plugins extra-settings) (let* ((plugins (directory-union "bitlbee-plugins" plugins)) (conf (mixed-text-file "bitlbee.conf" " [settings] User = bitlbee ConfigDir = /var/lib/bitlbee DaemonInterface = " interface " DaemonPort = " (number->string port) " PluginDir = " plugins "/lib/bitlbee " extra-settings)) (bitlbee* (least-authority-wrapper (file-append bitlbee "/sbin/bitlbee") #:name "bitlbee" #:preserved-environment-variables '("PURPLE_PLUGIN_PATH" "GUIX_LOCPATH" "LC_ALL") #:mappings (list (file-system-mapping (source "/var/lib/bitlbee") (target source) (writable? #t)) (file-system-mapping (source "/run/current-system/locale") (target source)) (file-system-mapping (source conf) (target conf))) #:namespaces (delq 'net %namespaces)))) (list (shepherd-service (provision '(bitlbee)) ;; Note: If networking is not up, then /etc/resolv.conf ;; doesn't get mapped in the container, hence the dependency ;; on 'networking'. (requirement '(user-processes networking)) (start #~(make-inetd-constructor (list #$bitlbee* "-I" "-c" #$conf) (list (endpoint (addrinfo:addr (car (getaddrinfo #$interface #$(number->string port) (logior AI_NUMERICHOST AI_NUMERICSERV)))))) #:requirements '#$requirement #:service-name-stem "bitlbee" #:user "bitlbee" #:group "bitlbee" ;; Allow 'bitlbee-purple' to use libpurple plugins. #:environment-variables (list (string-append "PURPLE_PLUGIN_PATH=" #$plugins "/lib/purple-2") "GUIX_LOCPATH=/run/current-system/locale"))) (stop #~(make-inetd-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 (file-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 shepherd-root-service-type bitlbee-shepherd-service) (service-extension account-service-type (const %bitlbee-accounts)) (service-extension activation-service-type (const %bitlbee-activation)))) (default-value (bitlbee-configuration)) (description "Run @url{http://bitlbee.org,BitlBee}, a daemon that acts as a gateway between IRC and chat networks."))) ;;; ;;; Quassel. ;;; (define-record-type* quassel-configuration make-quassel-configuration quassel-configuration? (quassel quassel-configuration-quassel (default quassel)) (interface quassel-configuration-interface (default "::,0.0.0.0")) (port quassel-configuration-port (default 4242)) (loglevel quassel-configuration-loglevel (default "Info"))) (define quassel-shepherd-service (match-lambda (($ quassel interface port loglevel) (let ((quassel (least-authority-wrapper (file-append quassel "/bin/quasselcore") #:name "quasselcore" #:mappings (list (file-system-mapping (source "/var/lib/quassel") (target source) (writable? #t)) (file-system-mapping (source "/var/log/quassel") (target source) (writable? #t))) ;; XXX: The daemon needs to live in the main user ;; namespace, as root, so it can access /var/lib/quassel ;; owned by "quasselcore". #:namespaces (fold delq %namespaces '(net user))))) (list (shepherd-service (provision '(quassel)) (requirement '(user-processes networking)) (start #~(make-forkexec-constructor (list #$quassel "--configdir=/var/lib/quassel" "--logfile=/var/log/quassel/core.log" (string-append "--loglevel=" #$loglevel) (string-append "--port=" (number->string #$port)) (string-append "--listen=" #$interface)))) (stop #~(make-kill-destructor)))))))) (define %quassel-account (list (user-group (name "quassel") (system? #t)) (user-account (name "quasselcore") (group "quassel") (system? #t) (comment "Quassel daemon user") (home-directory "/var/lib/quassel") (shell (file-append shadow "/sbin/nologin"))))) (define %quassel-activation #~(begin (use-modules (guix build utils)) (mkdir-p "/var/lib/quassel") (mkdir-p "/var/log/quassel") (let ((cert "/var/lib/quassel/quasselCert.pem")) (unless (file-exists? cert) (invoke #$(file-append openssl "/bin/openssl") "req" "-x509" "-nodes" "-batch" "-days" "680" "-newkey" "rsa" "-keyout" cert "-out" cert))))) (define quassel-service-type (service-type (name 'quassel) (extensions (list (service-extension shepherd-root-service-type quassel-shepherd-service) (service-extension profile-service-type (compose list quassel-configuration-quassel)) (service-extension account-service-type (const %quassel-account)) (service-extension activation-service-type (const %quassel-activation)))) (default-value (quassel-configuration)) (description "Run @url{https://quassel-irc.org/,quasselcore}, the backend for the distributed IRC client quassel, which allows you to connect from multiple machines simultaneously.")))