diff options
Diffstat (limited to 'gnu/services')
| -rw-r--r-- | gnu/services/certbot.scm | 185 | ||||
| -rw-r--r-- | gnu/services/cuirass.scm | 22 | ||||
| -rw-r--r-- | gnu/services/linux.scm | 2 | ||||
| -rw-r--r-- | gnu/services/networking.scm | 268 | ||||
| -rw-r--r-- | gnu/services/shepherd.scm | 14 | ||||
| -rw-r--r-- | gnu/services/virtualization.scm | 680 | ||||
| -rw-r--r-- | gnu/services/web.scm | 56 |
7 files changed, 1050 insertions, 177 deletions
diff --git a/gnu/services/certbot.scm b/gnu/services/certbot.scm index 0c45471659..f287c8367f 100644 --- a/gnu/services/certbot.scm +++ b/gnu/services/certbot.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2020 Jack Hill <jackhill@jackhill.us> ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> ;;; Copyright © 2021 Raghav Gururajan <rg@raghavgururajan.name> +;;; Copyright © 2024 Carlo Zancanaro <carlo@zancanaro.id.au> ;;; ;;; This file is part of GNU Guix. ;;; @@ -34,6 +35,7 @@ #:use-module (guix records) #:use-module (guix gexp) #:use-module (srfi srfi-1) + #:use-module (ice-9 format) #:use-module (ice-9 match) #:export (certbot-service-type certbot-configuration @@ -63,7 +65,9 @@ (cleanup-hook certificate-cleanup-hook (default #f)) (deploy-hook certificate-configuration-deploy-hook - (default #f))) + (default #f)) + (start-self-signed? certificate-configuration-start-self-signed? + (default #t))) (define-record-type* <certbot-configuration> certbot-configuration make-certbot-configuration @@ -87,6 +91,45 @@ (body (list "return 301 https://$host$request_uri;")))))) +(define (certbot-deploy-hook name deploy-hook-script) + "Returns a gexp which creates symlinks for privkey.pem and fullchain.pem +from /etc/certs/NAME to /etc/letsenctypt/live/NAME. If DEPLOY-HOOK-SCRIPT is +not #f then it is run after the symlinks have been created. This wrapping is +necessary for certificates with start-self-signed? set to #t, as it will +overwrite the initial self-signed certificates upon the first successful +deploy." + (program-file + (string-append name "-deploy-hook") + (with-imported-modules '((gnu services herd) + (guix build utils)) + #~(begin + (use-modules (gnu services herd) + (guix build utils)) + (mkdir-p #$(string-append "/etc/certs/" name)) + (chmod #$(string-append "/etc/certs/" name) #o755) + + ;; Create new symlinks + (symlink #$(string-append + "/etc/letsencrypt/live/" name "/privkey.pem") + #$(string-append "/etc/certs/" name "/privkey.pem.new")) + (symlink #$(string-append + "/etc/letsencrypt/live/" name "/fullchain.pem") + #$(string-append "/etc/certs/" name "/fullchain.pem.new")) + + ;; Rename over the top of the old ones, just in case they were the + ;; original self-signed certificates. + (rename-file #$(string-append "/etc/certs/" name "/privkey.pem.new") + #$(string-append "/etc/certs/" name "/privkey.pem")) + (rename-file #$(string-append "/etc/certs/" name "/fullchain.pem.new") + #$(string-append "/etc/certs/" name "/fullchain.pem")) + + ;; With the new certificates in place, tell nginx to reload them. + (with-shepherd-action 'nginx ('reload) result result) + + #$@(if deploy-hook-script + (list #~(invoke #$deploy-hook-script)) + '()))))) + (define certbot-command (match-lambda (($ <certbot-configuration> package webroot certificates email @@ -118,7 +161,8 @@ `("--manual-auth-hook" ,authentication-hook) '()) (if cleanup-hook `("--manual-cleanup-hook" ,cleanup-hook) '()) - (if deploy-hook `("--deploy-hook" ,deploy-hook) '())) + (list "--deploy-hook" + (certbot-deploy-hook name deploy-hook))) (append (list name certbot "certonly" "-n" "--agree-tos" "--webroot" "-w" webroot @@ -130,20 +174,51 @@ '("--register-unsafely-without-email")) (if server `("--server" ,server) '()) (if rsa-key-size `("--rsa-key-size" ,rsa-key-size) '()) - (if deploy-hook `("--deploy-hook" ,deploy-hook) '())))))) + (list "--deploy-hook" + (certbot-deploy-hook name deploy-hook))))))) certificates))) (program-file "certbot-command" #~(begin - (use-modules (ice-9 match)) - (let ((code 0)) + (use-modules (ice-9 match) + (ice-9 textual-ports)) + + (define (log format-string . args) + (apply format #t format-string args) + (force-output)) + + (define (file-contains? file string) + (string-contains (call-with-input-file file + get-string-all) + string)) + + (define (connection-error?) + ;; Certbot errors are always exit code 1, so we need to look at + ;; the log file to see if there was a connection error. + (file-contains? "/var/log/letsencrypt/letsencrypt.log" + "Failed to establish a new connection")) + + (let ((script-code 0)) (for-each (match-lambda ((name . command) - (begin - (format #t "Acquiring or renewing certificate: ~a~%" name) - (set! code (or (apply system* command) code))))) - '#$commands) code))))))) + (log "Acquiring or renewing certificate: ~a~%" name) + (cond + ((zero? (status:exit-val (apply system* command))) + (log "Certificate successfully acquired: ~a~%" name)) + ((connection-error?) + ;; If we have a connection error, then bail early with + ;; exit code 2. We don't expect this to resolve within the + ;; timespan of this script. + (log "Connection error - bailing out~%") + (exit 2)) + (else + ;; If we have any other type of error, then continue but + ;; exit with a failing status code in the end. + (log "Error: ~a - continuing with other domains~%" name) + (set! script-code 1))))) + '#$commands) + (exit script-code)))))))) (define (certbot-renewal-jobs config) (list @@ -152,11 +227,84 @@ #~(job '(next-minute-from (next-hour '(0 12)) (list (random 60))) #$(certbot-command config)))) +(define (certbot-renewal-one-shot config) + (list + ;; Renew certificates when the system first starts. This is a one-shot + ;; service, because the mcron configuration will take care of running this + ;; periodically. This is most useful the very first time the system starts, + ;; to overwrite our self-signed certificates as soon as possible without + ;; user intervention. + (shepherd-service + (provision '(renew-certbot-certificates)) + (requirement '(nginx)) + (one-shot? #t) + (start #~(lambda _ + ;; This needs the network, but there's no reliable way to know + ;; if the network is up other than trying. If we fail due to a + ;; connection error we retry a number of times in the hope that + ;; the network comes up soon. + (let loop ((attempt 0)) + (let ((code (status:exit-val + (system* #$(certbot-command config))))) + (cond + ((and (= code 2) ; Exit code 2 means connection error + (< attempt 12)) ; Arbitrarily chosen max attempts + (sleep 10) ; Arbitrarily chosen retry delay + (loop (1+ attempt))) + ((zero? code) + ;; Success! + #t) + (else + ;; Failure. + #f)))))) + (auto-start? #t) + (documentation "Call certbot to renew certificates.") + (actions (list (shepherd-configuration-action (certbot-command config))))))) + +(define (generate-certificate-gexp certbot-cert-directory rsa-key-size) + (match-lambda + (($ <certificate-configuration> name (primary-domain other-domains ...) + challenge + csr authentication-hook + cleanup-hook deploy-hook) + (let (;; Arbitrary default subject, with just the + ;; right domain filled in. These values don't + ;; have any real significance. + (subject (string-append + "/C=US/ST=Oregon/L=Portland/O=Company Name/OU=Org/CN=" + primary-domain)) + (alt-names (if (null? other-domains) + #f + (format #f "subjectAltName=~{DNS:~a~^,~}" + other-domains))) + (directory (string-append "/etc/certs/" (or name primary-domain)))) + #~(when (not (file-exists? #$directory)) + ;; We generate self-signed certificates in /etc/certs/{domain}, + ;; because certbot is very sensitive to its directory + ;; structure. It refuses to write over the top of existing files, + ;; so we need to use a directory outside of its control. + ;; + ;; These certificates are overwritten by the certbot deploy hook + ;; the first time it successfully obtains a letsencrypt-signed + ;; certificate. + (mkdir-p #$directory) + (chmod #$directory #o755) + (invoke #$(file-append openssl "/bin/openssl") + "req" "-x509" + "-newkey" #$(string-append "rsa:" (or rsa-key-size "4096")) + "-keyout" #$(string-append directory "/privkey.pem") + "-out" #$(string-append directory "/fullchain.pem") + "-sha256" + "-days" "1" ; Only one day, because we expect certbot to run + "-nodes" + "-subj" #$subject + #$@(if alt-names + (list "-addext" alt-names) + (list)))))))) + (define (certbot-activation config) (let* ((certbot-directory "/var/lib/certbot") - (certbot-cert-directory "/etc/letsencrypt/live") - (script (in-vicinity certbot-directory "renew-certificates")) - (message (format #f (G_ "~a may need to be run~%") script))) + (certbot-cert-directory "/etc/letsencrypt/live")) (match config (($ <certbot-configuration> package webroot certificates email server rsa-key-size default-location) @@ -166,8 +314,13 @@ (mkdir-p #$webroot) (mkdir-p #$certbot-directory) (mkdir-p #$certbot-cert-directory) - (copy-file #$(certbot-command config) #$script) - (display #$message))))))) + + #$@(let ((rsa-key-size (and rsa-key-size + (number->string rsa-key-size)))) + (map (generate-certificate-gexp certbot-cert-directory + rsa-key-size) + (filter certificate-configuration-start-self-signed? + certificates))))))))) (define certbot-nginx-server-configurations (match-lambda @@ -200,7 +353,9 @@ (service-extension activation-service-type certbot-activation) (service-extension mcron-service-type - certbot-renewal-jobs))) + certbot-renewal-jobs) + (service-extension shepherd-root-service-type + certbot-renewal-one-shot))) (compose concatenate) (extend (lambda (config additional-certificates) (certbot-configuration diff --git a/gnu/services/cuirass.scm b/gnu/services/cuirass.scm index fcbd5e08a5..bcdbffa2f3 100644 --- a/gnu/services/cuirass.scm +++ b/gnu/services/cuirass.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org> -;;; Copyright © 2016-2023 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016-2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net> @@ -136,7 +136,9 @@ (database (cuirass-configuration-database config)) (port (cuirass-configuration-port config)) (host (cuirass-configuration-host config)) - (specs (cuirass-configuration-specifications config)) + (config-file (scheme-file + "cuirass-specs.scm" + (cuirass-configuration-specifications config))) (use-substitutes? (cuirass-configuration-use-substitutes? config)) (one-shot? (cuirass-configuration-one-shot? config)) (fallback? (cuirass-configuration-fallback? config)) @@ -144,13 +146,14 @@ `(,(shepherd-service (documentation "Run Cuirass.") (provision '(cuirass)) - (requirement '(guix-daemon postgres postgres-roles networking)) + (requirement '(user-processes + guix-daemon + postgres postgres-roles networking)) (start #~(make-forkexec-constructor (list (string-append #$cuirass "/bin/cuirass") "register" "--cache-directory" #$cache-directory - "--specifications" - #$(scheme-file "cuirass-specs.scm" specs) + "--specifications" #$config-file "--database" #$database "--interval" #$(number->string interval) #$@(if parameters @@ -172,11 +175,12 @@ #:user #$user #:group #$group #:log-file #$main-log-file)) - (stop #~(make-kill-destructor))) + (stop #~(make-kill-destructor)) + (actions (list (shepherd-configuration-action config-file)))) ,(shepherd-service (documentation "Run Cuirass web interface.") (provision '(cuirass-web)) - (requirement '(cuirass)) + (requirement '(user-processes cuirass)) (start #~(make-forkexec-constructor (list (string-append #$cuirass "/bin/cuirass") "web" @@ -202,7 +206,7 @@ (shepherd-service (documentation "Run Cuirass remote build server.") (provision '(cuirass-remote-server)) - (requirement '(avahi-daemon cuirass)) + (requirement '(user-processes avahi-daemon cuirass)) (start #~(make-forkexec-constructor (list (string-append #$cuirass "/bin/cuirass") "remote-server" @@ -373,7 +377,7 @@ CONFIG." (list (shepherd-service (documentation "Run Cuirass remote build worker.") (provision '(cuirass-remote-worker)) - (requirement '(avahi-daemon guix-daemon networking)) + (requirement '(user-processes avahi-daemon guix-daemon networking)) (start #~(make-forkexec-constructor (list (string-append #$cuirass "/bin/cuirass") "remote-worker" diff --git a/gnu/services/linux.scm b/gnu/services/linux.scm index 9ee0d93030..9955a11e64 100644 --- a/gnu/services/linux.scm +++ b/gnu/services/linux.scm @@ -291,7 +291,7 @@ more information)." (shepherd-service (documentation "Load kernel modules.") (provision '(kernel-module-loader)) - (requirement '()) + (requirement '(udev)) (one-shot? #t) (modules `((srfi srfi-1) (srfi srfi-34) diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm index 7c114fa53c..8e64e529ab 100644 --- a/gnu/services/networking.scm +++ b/gnu/services/networking.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013-2023 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013-2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2016, 2018, 2020 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2016 John Darrington <jmd@gnu.org> @@ -21,6 +21,7 @@ ;;; Copyright © 2022, 2023 Andrew Tropin <andrew@trop.in> ;;; Copyright © 2023 Declan Tsien <declantsien@riseup.net> ;;; Copyright © 2023 Bruno Victal <mirai@makinata.eu> +;;; Copyright © 2023 muradm <mail@muradm.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -78,6 +79,7 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-43) #:use-module (ice-9 match) + #:use-module (ice-9 string-fun) #:use-module (json) #:re-export (static-networking-service static-networking-service-type) @@ -171,6 +173,8 @@ network-manager-configuration-vpn-plugins network-manager-service-type + connman-general-configuration + connman-general-configuration? connman-configuration connman-configuration? connman-configuration-connman @@ -266,6 +270,14 @@ ;;; ;;; Code: +(define %unroutable-ipv4 + ;; Unroutable address, as per <https://www.rfc-editor.org/rfc/rfc5737>. + "203.0.113.1") + +(define %unroutable-ipv6 + ;; Unroutable address, as per <https://www.rfc-editor.org/rfc/rfc6666>. + "0100::") + (define facebook-host-aliases ;; This is the list of known Facebook hosts to be added to /etc/hosts if you ;; are to block it. @@ -278,7 +290,8 @@ (append-map (lambda (name) (map (lambda (addr) (host addr name)) - (list "127.0.0.1" "::1"))) domains))) + (list %unroutable-ipv4 %unroutable-ipv6))) + domains))) (define-deprecated %facebook-host-aliases block-facebook-hosts-service-type @@ -1326,6 +1339,241 @@ wireless networking.")))) ;;; Connman ;;; +(define (connman-general-configuration-field-name field-name) + (let* ((str->camel (lambda (s) + (string-concatenate + (map string-capitalize (string-split s #\-))))) + (str (if (symbol? field-name) + (str->camel (symbol->string field-name)) + field-name))) + (cond + ((string-suffix? "?" str) (connman-general-configuration-field-name + (string-drop-right str 1))) + ((string-contains str "RegulatoryDomain") (connman-general-configuration-field-name + (string-replace-substring str "RegulatoryDomain" "Regdom"))) + ((string-contains str "Url") (connman-general-configuration-field-name + (string-replace-substring str "Url" "URL"))) + ((string-contains str "Ip") (connman-general-configuration-field-name + (string-replace-substring str "Ip" "IP"))) + ((string-contains str "6To4") (connman-general-configuration-field-name + (string-replace-substring str "6To4" "6to4"))) + (#t str)))) + +(define (connman-general-configuration-serialize-string field-name value) + (let ((param (connman-general-configuration-field-name field-name))) + #~(string-append #$param " = " #$value "\n"))) + +(define (connman-general-configuration-serialize-number field-name value) + (connman-general-configuration-serialize-string + field-name (number->string value))) + +(define (connman-general-configuration-serialize-list field-name value) + (connman-general-configuration-serialize-string + field-name (string-join value ","))) + +(define (connman-general-configuration-serialize-boolean field-name value) + (connman-general-configuration-serialize-string + field-name (if value "true" "false"))) + +(define-maybe boolean (prefix connman-general-configuration-)) +(define-maybe number (prefix connman-general-configuration-)) +(define-maybe string (prefix connman-general-configuration-)) +(define-maybe list (prefix connman-general-configuration-)) + +(define-configuration connman-general-configuration + (input-request-timeout + maybe-number + "Set input request timeout. Default is 120 seconds. The request for inputs +like passphrase will timeout after certain amount of time. Use this setting to +increase the value in case of different user interface designs.") + (browser-launch-timeout + maybe-number + "Set browser launch timeout. Default is 300 seconds. The request for +launching a browser for portal pages will timeout after certain amount of +time. Use this setting to increase the value in case of different user +interface designs.") + (background-scanning? + maybe-boolean + "Enable background scanning. Default is true. If wifi is disconnected, the +background scanning will follow a simple back off mechanism from 3s up to 5 +minutes. Then, it will stay in 5 minutes unless user specifically asks for +scanning through a D-Bus call. If so, the mechanism will start again from +3s. This feature activates also the background scanning while being connected, +which is required for roaming on wifi. When @code{background-scanning?} is false, +ConnMan will not perform any scan regardless of wifi is connected or not, +unless it is requested by the user through a D-Bus call.") + (use-gateways-as-timeservers? + maybe-boolean + "Assume that service gateways also function as timeservers. Default is false.") + (fallback-timeservers + maybe-list + "List of Fallback timeservers. These timeservers are used for NTP sync +when there are no timeservers set by the user or by the service, and when +@code{use-gateways-as-timeservers?} is @code{#f}. These can contain a mixed +combination of fully qualified domain names, IPv4 and IPv6 addresses.") + (fallback-nameservers + maybe-list + "List of fallback nameservers appended to the list of nameservers given +by the service. The nameserver entries must be in numeric format, +host names are ignored.") + (default-auto-connect-technologies + maybe-list + "List of technologies that are marked autoconnectable by default. The +default value for this entry when empty is @code{\"ethernet\"}, @code{\"wifi\"}, +@code{\"cellular\"}. Services that are automatically connected must have been +set up and saved to storage beforehand.") + (default-favourite-technologies + maybe-list + "List of technologies that are marked favorite by default. The default +value for this entry when empty is @code{\"ethernet\"}. Connects to services +from this technology even if not setup and saved to storage.") + (always-connected-technologies + maybe-list + "List of technologies which are always connected regardless of +preferred-technologies setting (@code{auto-connect?} @code{#t}). The default +value is empty and this feature is disabled unless explicitly enabled.") + (preferred-technologies + maybe-list + "List of preferred technologies from the most preferred one to the least +preferred one. Services of the listed technology type will be tried one by +one in the order given, until one of them gets connected or they are all +tried. A service of a preferred technology type in state 'ready' will get +the default route when compared to another preferred type further down the +list with state 'ready' or with a non-preferred type; a service of a +preferred technology type in state 'online' will get the default route when +compared to either a non-preferred type or a preferred type further down +in the list.") + (network-interface-blacklist + maybe-list + "List of blacklisted network interfaces. Found interfaces will be +compared to the list and will not be handled by ConnMan, if their first +characters match any of the list entries. Default value is @code{\"vmnet\"}, +@code{\"vboxnet\"}, @code{\"virbr\"}, @code{\"ifb\"}.") + (allow-hostname-updates? + maybe-boolean + "Allow ConnMan to change the system hostname. This can happen for +example if we receive DHCP hostname option. Default value is @code{#t}.") + (allow-domainname-updates? + maybe-boolean + "Allow connman to change the system domainname. This can happen for +example if we receive DHCP domainname option. Default value is @code{#t}.") + (single-connected-technology? + maybe-boolean + "Keep only a single connected technology at any time. When a new +service is connected by the user or a better one is found according to +preferred-technologies, the new service is kept connected and all the +other previously connected services are disconnected. With this setting +it does not matter whether the previously connected services are +in 'online' or 'ready' states, the newly connected service is the only +one that will be kept connected. A service connected by the user will +be used until going out of network coverage. With this setting enabled +applications will notice more network breaks than normal. Note this +options can't be used with VPNs. Default value is @code{#f}.") + (tethering-technologies + maybe-list + "List of technologies that are allowed to enable tethering. The +default value is @code{\"wifi\"}, @code{\"bluetooth\"}, +@code{\"gadget\"}. Only those technologies listed here are used for +tethering. If one wants to tether ethernet, then add @code{\"ethernet\"} +in the list. Note that if ethernet tethering is enabled, then a DHCP +server is started on all ethernet interfaces. Tethered ethernet should +never be connected to corporate or home network as it will disrupt normal +operation of these networks. Due to this ethernet is not tethered by +default. Do not activate ethernet tethering unless you really know +what you are doing.") + (persistent-tethering-mode? + maybe-boolean + "Restore earlier tethering status when returning from offline mode, +re-enabling a technology, and after restarts and reboots. Default +value is @code{#f}.") + (enable-6to4? + maybe-boolean + "Automatically enable anycast 6to4 if possible. This is not +recommended, as the use of 6to4 will generally lead to a severe +degradation of connection quality. See RFC6343. Default value +is @code{#f} (as recommended by RFC6343 section 4.1).") + (vendor-class-id + maybe-string + "Set DHCP option 60 (Vendor Class ID) to the given string. This +option can be used by DHCP servers to identify specific clients +without having to rely on MAC address ranges, etc.") + (enable-online-check? + maybe-boolean + "Enable or disable use of HTTP GET as an online status check. When +a service is in a READY state, and is selected as default, ConnMan will +issue an HTTP GET request to verify that end-to-end connectivity is +successful. Only then the service will be transitioned to ONLINE +state. If this setting is false, the default service will remain +in READY state. Default value is @code{#t}.") + (online-check-ipv4-url + maybe-string + "IPv4 URL used during the online status check. Please refer to +the README for more detailed information. Default value is +@url{http://ipv4.connman.net/online/status.html}.") + (online-check-ipv6-url + maybe-string + "IPv6 URL used during the online status check. Please refer to +the README for more detailed information. Default value is +@url{http://ipv6.connman.net/online/status.html}.") + (online-check-initial-interval + maybe-number + "Range of intervals between two online check requests. Please +refer to the README for more detailed information. Default value +is @samp{1}.") + (online-check-max-interval + maybe-number + "Range of intervals between two online check requests. Please +refer to the README for more detailed information. Default value +is @samp{1}.") + (enable-online-to-ready-transition? + maybe-boolean + "WARNING: This is an experimental feature. In addition to +@code{enable-online-check} setting, enable or disable use of HTTP GET +to detect the loss of end-to-end connectivity. If this setting is +@code{#f}, when the default service transitions to ONLINE state, the +HTTP GET request is no more called until next cycle, initiated by a +transition of the default service to DISCONNECT state. If this +setting is @code{#t}, the HTTP GET request keeps being called to +guarantee that end-to-end connectivity is still successful. If not, +the default service will transition to READY state, enabling another +service to become the default one, in replacement. Default value +is @code{#f}.") + (auto-connect-roaming-services? + maybe-boolean + "Automatically connect roaming services. This is not recommended +unless you know you won't have any billing problem. Default value +is @code{#f}.") + (address-conflict-detection? + maybe-boolean + "Enable or disable the implementation of IPv4 address conflict +detection according to RFC5227. ConnMan will send probe ARP packets +to see if an IPv4 address is already in use before assigning the +address to an interface. If an address conflict occurs for a +statically configured address, an IPv4LL address will be chosen +instead (according to RFC3927). If an address conflict occurs for +an address offered via DHCP, ConnMan sends a DHCP DECLINE once +and for the second conflict resorts to finding an IPv4LL +address. Default value is @code{#f}.") + (localtime + maybe-string + "Path to localtime file. Defaults to @file{/etc/localtime}.") + (regulatory-domain-follows-timezone? + maybe-boolean + "Enable regulatory domain to be changed along timezone changes. +With this option set to true each time the timezone changes the first +present ISO3166 country code is read from +@file{/usr/share/zoneinfo/zone1970.tab} and set as regulatory domain +value. Default value is @code{#f}.") + (resolv-conf + maybe-string + "Path to resolv.conf file. If the file does not exist, but +intermediate directories exist, it will be created. If this option +is not set, it tries to write into @file{/var/run/connman/resolv.conf} +if it fails (@file{/var/run/connman} does not exist or is not +writeable). If you do not want to update resolv.conf, you can +set @file{/dev/null}.") + (prefix connman-general-configuration-)) + (define-record-type* <connman-configuration> connman-configuration make-connman-configuration connman-configuration? @@ -1337,7 +1585,9 @@ wireless networking.")))) (default #f)) (iwd? connman-configuration-iwd? (default #f) - (sanitize warn-iwd?-field-deprecation))) + (sanitize warn-iwd?-field-deprecation)) + (general-configuration connman-configuration-general-configuration + (default (connman-general-configuration)))) (define (connman-activation config) (let ((disable-vpn? (connman-configuration-disable-vpn? config))) @@ -1350,10 +1600,17 @@ wireless networking.")))) (define (connman-shepherd-service config) (match-record config <connman-configuration> (connman shepherd-requirement - disable-vpn? iwd?) + disable-vpn? iwd? + general-configuration) (let ((iwd? (or iwd? ; TODO: deprecated field, remove later. (and shepherd-requirement - (memq 'iwd shepherd-requirement))))) + (memq 'iwd shepherd-requirement)))) + (config (mixed-text-file + "main.conf" + "[General]\n" + (serialize-configuration + general-configuration + connman-general-configuration-fields)))) (list (shepherd-service (documentation "Run Connman") (provision '(connman networking)) @@ -1365,6 +1622,7 @@ wireless networking.")))) (start #~(make-forkexec-constructor (list (string-append #$connman "/sbin/connmand") + (string-append "--config=" #$config) "--nodaemon" "--nodnsproxy" #$@(if disable-vpn? '("--noplugin=vpn") '()) diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm index 5ebac129ce..f5bcde721f 100644 --- a/gnu/services/shepherd.scm +++ b/gnu/services/shepherd.scm @@ -55,6 +55,8 @@ shepherd-service-canonical-name shepherd-service-requirement shepherd-service-one-shot? + shepherd-service-respawn-limit + shepherd-service-respawn-delay shepherd-service-respawn? shepherd-service-start shepherd-service-stop @@ -211,6 +213,10 @@ DEFAULT is given, use it as the service's default value." (default #f)) (respawn? shepherd-service-respawn? ;Boolean (default #t)) + (respawn-limit shepherd-service-respawn-limit + (default #f)) + (respawn-delay shepherd-service-respawn-delay + (default #f)) (start shepherd-service-start) ;g-expression (procedure) (stop shepherd-service-stop ;g-expression (procedure) (default #~(const #f))) @@ -309,6 +315,14 @@ stored." #:one-shot? '#$(shepherd-service-one-shot? service) #:respawn? '#$(shepherd-service-respawn? service) + #$@(if (shepherd-service-respawn-limit service) + `(#:respawn-limit + ,(shepherd-service-respawn-limit service)) + '()) + #$@(if (shepherd-service-respawn-delay service) + `(#:respawn-delay + ,(shepherd-service-respawn-delay service)) + '()) #:start #$(shepherd-service-start service) #:stop #$(shepherd-service-stop service) #:actions diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm index f0f0ab3bf1..7b04ddb35e 100644 --- a/gnu/services/virtualization.scm +++ b/gnu/services/virtualization.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Ryan Moe <ryan.moe@gmail.com> -;;; Copyright © 2018, 2020-2023 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2020-2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2020, 2021, 2023 Janneke Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2021 Timotej Lazar <timotej.lazar@araneo.si> ;;; Copyright © 2022 Oleg Pykhalov <go.wigust@gmail.com> @@ -36,6 +36,7 @@ #:use-module (gnu services base) #:use-module (gnu services configuration) #:use-module (gnu services dbus) + #:use-module (gnu services mcron) #:use-module (gnu services shepherd) #:use-module (gnu services ssh) #:use-module (gnu services) @@ -43,6 +44,8 @@ #:use-module (gnu system hurd) #:use-module (gnu system image) #:use-module (gnu system shadow) + #:autoload (gnu system vm) (linux-image-startup-command + virtualized-operating-system) #:use-module (gnu system) #:use-module (guix derivations) #:use-module (guix gexp) @@ -55,12 +58,20 @@ #:autoload (guix self) (make-config.scm) #:autoload (guix platform) (platform-system) + #:use-module ((srfi srfi-1) #:hide (partition)) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) - #:export (%hurd-vm-operating-system + #:export (virtual-build-machine + virtual-build-machine-service-type + + %virtual-build-machine-operating-system + %virtual-build-machine-default-vm + + %hurd-vm-operating-system hurd-vm-configuration hurd-vm-configuration? hurd-vm-configuration-os @@ -996,7 +1007,7 @@ specified, the QEMU default path is used.")) ;;; Secrets for guest VMs. ;;; -(define (secret-service-shepherd-services port) +(define (secret-service-shepherd-services address) "Return a Shepherd service that fetches sensitive material at local PORT, over TCP. Reboot upon failure." ;; This is a Shepherd service, rather than an activation snippet, to make @@ -1018,7 +1029,7 @@ over TCP. Reboot upon failure." "receiving secrets from the host...~%") (force-output (current-error-port)) - (let ((sent (secret-service-receive-secrets #$port))) + (let ((sent (secret-service-receive-secrets #$address))) (unless sent (sleep 3) (reboot)))))) @@ -1039,9 +1050,13 @@ over TCP. Reboot upon failure." boot time. This service is meant to be used by virtual machines (VMs) that can only be accessed by their host."))) -(define (secret-service-operating-system os) +(define* (secret-service-operating-system os + #:optional + (address + #~(make-socket-address + AF_INET INADDR_ANY 1004))) "Return an operating system based on OS that includes the secret-service, -that will be listening to receive secret keys on port 1004, TCP." +that will be listening to receive secret keys on ADDRESS." (operating-system (inherit os) (services @@ -1049,7 +1064,7 @@ that will be listening to receive secret keys on port 1004, TCP." ;; activation: that requires entropy and thus takes time during boot, and ;; those keys are going to be overwritten by secrets received from the ;; host anyway. - (cons (service secret-service-type 1004) + (cons (service secret-service-type address) (modify-services (operating-system-user-services os) (openssh-service-type config => (openssh-configuration @@ -1062,6 +1077,498 @@ that will be listening to receive secret keys on port 1004, TCP." ;;; +;;; Offloading-as-a-service. +;;; + +(define-record-type* <virtual-build-machine> + virtual-build-machine make-virtual-build-machine + virtual-build-machine? + this-virtual-build-machine + (name virtual-build-machine-name + (default 'build-vm)) + (image virtual-build-machine-image + (thunked) + (default + (virtual-build-machine-default-image + this-virtual-build-machine))) + (qemu virtual-build-machine-qemu + (default qemu-minimal)) + (cpu virtual-build-machine-cpu + (thunked) + (default + (qemu-cpu-model-for-date + (virtual-build-machine-systems this-virtual-build-machine) + (virtual-build-machine-date this-virtual-build-machine)))) + (cpu-count virtual-build-machine-cpu-count + (default 4)) + (memory-size virtual-build-machine-memory-size ;integer (MiB) + (default 2048)) + (date virtual-build-machine-date + ;; Default to a date "in the past" assuming a common use case + ;; is to rebuild old packages. + (default (make-date 0 0 00 00 01 01 2020 0))) + (port-forwardings virtual-build-machine-port-forwardings + (default + `((,%build-vm-ssh-port . 22) + (,%build-vm-secrets-port . 1004)))) + (systems virtual-build-machine-systems + (default (list (%current-system)))) + (auto-start? virtual-build-machine-auto-start? + (default #f))) + +(define %build-vm-ssh-port + ;; Default host port where the guest's SSH port is forwarded. + 11022) + +(define %build-vm-secrets-port + ;; Host port to communicate secrets to the build VM. + ;; FIXME: Anyone on the host can talk to it; use virtio ports or AF_VSOCK + ;; instead. + 11044) + +(define %x86-64-intel-cpu-models + ;; List of release date/CPU model pairs representing Intel's x86_64 models. + ;; The list is taken from + ;; <https://en.wikipedia.org/wiki/List_of_Intel_CPU_microarchitectures>. + ;; CPU model strings are those found in 'qemu-system-x86_64 -cpu help'. + (letrec-syntax ((cpu-models (syntax-rules () + ((_ (date model) rest ...) + (alist-cons (date->time-utc + (string->date date "~Y-~m-~d")) + model + (cpu-models rest ...))) + ((_) + '())))) + (reverse + (cpu-models ("2006-01-01" "core2duo") + ("2010-01-01" "Westmere") + ("2008-01-01" "Nehalem") + ("2011-01-01" "SandyBridge") + ("2012-01-01" "IvyBridge") + ("2013-01-01" "Haswell") + ("2014-01-01" "Broadwell") + ("2015-01-01" "Skylake-Client"))))) + +(define (qemu-cpu-model-for-date systems date) + "Return the QEMU name of a CPU model for SYSTEMS that was current at DATE." + (if (any (cut string-prefix? "x86_64-" <>) systems) + (let ((time (date->time-utc date))) + (any (match-lambda + ((release-date . model) + (and (time<? release-date time) + model))) + %x86-64-intel-cpu-models)) + ;; TODO: Add models for other architectures. + "host")) + +(define (virtual-build-machine-ssh-port config) + "Return the host port where CONFIG has its VM's SSH port forwarded." + (any (match-lambda + ((host-port . 22) host-port) + (_ #f)) + (virtual-build-machine-port-forwardings config))) + +(define (virtual-build-machine-secrets-port config) + "Return the host port where CONFIG has its VM's secrets port forwarded." + (any (match-lambda + ((host-port . 1004) host-port) + (_ #f)) + (virtual-build-machine-port-forwardings config))) + +(define %minimal-vm-syslog-config + ;; Minimal syslog configuration for a VM. + (plain-file "vm-syslog.conf" "\ +# Log most messages to the console, which goes to the serial +# output, allowing the host to log it. +*.info;auth.notice;authpriv.none -/dev/console + +# The rest. +*.=debug -/var/log/debug +authpriv.*;auth.info /var/log/secure +")) + +(define %virtual-build-machine-operating-system + (operating-system + (host-name "build-machine") + (bootloader (bootloader-configuration ;unused + (bootloader grub-minimal-bootloader) + (targets '("/dev/null")))) + (file-systems (cons (file-system ;unused + (mount-point "/") + (device "none") + (type "tmpfs")) + %base-file-systems)) + (users (cons (user-account + (name "offload") + (group "users") + (supplementary-groups '("kvm")) + (comment "Account used for offloading")) + %base-user-accounts)) + (services (cons* (service static-networking-service-type + (list %qemu-static-networking)) + (service openssh-service-type + (openssh-configuration + (openssh openssh-sans-x))) + + ;; Run GC once per hour. + (simple-service 'perdiodic-gc mcron-service-type + (list #~(job "12 * * * *" + "guix gc -F 2G"))) + + (modify-services %base-services + ;; By default, the secret service introduces a + ;; pre-initialized /etc/guix/acl file in the VM. Thus, + ;; clear 'authorize-key?' so that it's not overridden + ;; at activation time. + (guix-service-type config => + (guix-configuration + (inherit config) + (authorize-key? #f))) + (syslog-service-type config => + (syslog-configuration + (config-file + %minimal-vm-syslog-config))) + (delete mingetty-service-type) + (delete console-font-service-type)))))) + +(define %default-virtual-build-machine-image-size + ;; Size of the default disk image of virtual build machines. It should be + ;; large enough to let users build a few things. + (* 20 (expt 2 30))) + +(define (virtual-build-machine-default-image config) + (let* ((type (lookup-image-type-by-name 'mbr-raw)) + (base (os->image %virtual-build-machine-operating-system + #:type type))) + (image (inherit base) + (name (symbol-append 'build-vm- + (virtual-build-machine-name config))) + (format 'compressed-qcow2) + (partition-table-type 'mbr) + (volatile-root? #f) + (shared-store? #f) + (size %default-virtual-build-machine-image-size) + (partitions (match (image-partitions base) + ((root) + ;; Increase the size of the root partition to match + ;; that of the disk image. + (let ((root-size (- size (* 50 (expt 2 20))))) + (list (partition + (inherit root) + (size root-size)))))))))) + +(define (virtual-build-machine-account-name config) + (string-append "build-vm-" + (symbol->string + (virtual-build-machine-name config)))) + +(define (virtual-build-machine-accounts config) + (let ((name (virtual-build-machine-account-name config))) + (list (user-group (name name) (system? #t)) + (user-account + (name name) + (group name) + (supplementary-groups '("kvm")) + (comment "Privilege separation user for the virtual build machine") + (home-directory "/var/empty") + (shell (file-append shadow "/sbin/nologin")) + (system? #t))))) + +(define (build-vm-shepherd-services config) + (define transform + (compose secret-service-operating-system + operating-system-with-locked-root-account + operating-system-with-offloading-account + (lambda (os) + (virtualized-operating-system os #:full-boot? #t)))) + + (define transformed-image + (let ((base (virtual-build-machine-image config))) + (image + (inherit base) + (operating-system + (transform (image-operating-system base)))))) + + (define command + (linux-image-startup-command transformed-image + #:qemu + (virtual-build-machine-qemu config) + #:cpu + (virtual-build-machine-cpu config) + #:cpu-count + (virtual-build-machine-cpu-count config) + #:memory-size + (virtual-build-machine-memory-size config) + #:port-forwardings + (virtual-build-machine-port-forwardings + config) + #:date + (virtual-build-machine-date config))) + + (define user + (virtual-build-machine-account-name config)) + + (list (shepherd-service + (documentation "Run the build virtual machine service.") + (provision (list (virtual-build-machine-name config))) + (requirement '(user-processes)) + (modules `((gnu build secret-service) + (guix build utils) + ,@%default-modules)) + (start + (with-imported-modules (source-module-closure + '((gnu build secret-service) + (guix build utils))) + #~(lambda arguments + (let* ((pid (fork+exec-command (append #$command arguments) + #:user #$user + #:group "kvm" + #:environment-variables + ;; QEMU tries to write to /var/tmp + ;; by default. + '("TMPDIR=/tmp"))) + (port #$(virtual-build-machine-secrets-port config)) + (root #$(virtual-build-machine-secret-root config)) + (address (make-socket-address AF_INET INADDR_LOOPBACK + port))) + (catch #t + (lambda _ + (if (secret-service-send-secrets address root) + pid + (begin + (kill (- pid) SIGTERM) + #f))) + (lambda (key . args) + (kill (- pid) SIGTERM) + (apply throw key args))))))) + (stop #~(make-kill-destructor)) + (actions + (list (shepherd-action + (name 'configuration) + (documentation + "Display the configuration of this virtual build machine.") + (procedure + #~(lambda (_) + (format #t "CPU: ~a~%" + #$(virtual-build-machine-cpu config)) + (format #t "number of CPU cores: ~a~%" + #$(virtual-build-machine-cpu-count config)) + (format #t "memory size: ~a MiB~%" + #$(virtual-build-machine-memory-size config)) + (format #t "initial date: ~a~%" + #$(date->string + (virtual-build-machine-date config)))))))) + (auto-start? (virtual-build-machine-auto-start? config))))) + +(define (authorize-guest-substitutes-on-host) + "Return a program that authorizes the guest's archive signing key (passed as +an argument) on the host." + (define not-config? + (match-lambda + ('(guix config) #f) + (('guix _ ...) #t) + (('gnu _ ...) #t) + (_ #f))) + + (define run + (with-extensions (list guile-gcrypt) + (with-imported-modules `(((guix config) => ,(make-config.scm)) + ,@(source-module-closure + '((guix pki) + (guix build utils)) + #:select? not-config?)) + #~(begin + (use-modules (ice-9 match) + (ice-9 textual-ports) + (gcrypt pk-crypto) + (guix pki) + (guix build utils)) + + (match (command-line) + ((_ guest-config-directory) + (let ((guest-key (string-append guest-config-directory + "/signing-key.pub"))) + (if (file-exists? guest-key) + ;; Add guest key to the host's ACL. + (let* ((key (string->canonical-sexp + (call-with-input-file guest-key + get-string-all))) + (acl (public-keys->acl + (cons key (acl->public-keys (current-acl)))))) + (with-atomic-file-replacement %acl-file + (lambda (_ port) + (write-acl acl port)))) + (format (current-error-port) + "warning: guest key missing from '~a'~%" + guest-key))))))))) + + (program-file "authorize-guest-substitutes-on-host" run)) + +(define (initialize-build-vm-substitutes) + "Initialize the Hurd VM's key pair and ACL and store it on the host." + (define run + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (ice-9 match)) + + (define host-key + "/etc/guix/signing-key.pub") + + (define host-acl + "/etc/guix/acl") + + (match (command-line) + ((_ guest-config-directory) + (setenv "GUIX_CONFIGURATION_DIRECTORY" + guest-config-directory) + (invoke #+(file-append guix "/bin/guix") "archive" + "--generate-key") + + (when (file-exists? host-acl) + ;; Copy the host ACL. + (copy-file host-acl + (string-append guest-config-directory + "/acl"))) + + (when (file-exists? host-key) + ;; Add the host key to the childhurd's ACL. + (let ((key (open-fdes host-key O_RDONLY))) + (close-fdes 0) + (dup2 key 0) + (execl #+(file-append guix "/bin/guix") + "guix" "archive" "--authorize")))))))) + + (program-file "initialize-build-vm-substitutes" run)) + +(define* (build-vm-activation secret-directory + #:key + offloading-ssh-key + (offloading? #t)) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + + (define secret-directory + #$secret-directory) + + (define ssh-directory + (string-append secret-directory "/etc/ssh")) + + (define guix-directory + (string-append secret-directory "/etc/guix")) + + (define offloading-ssh-key + #$offloading-ssh-key) + + (unless (file-exists? ssh-directory) + ;; Generate SSH host keys under SSH-DIRECTORY. + (mkdir-p ssh-directory) + (invoke #$(file-append openssh "/bin/ssh-keygen") + "-A" "-f" secret-directory)) + + (unless (or (not #$offloading?) + (file-exists? offloading-ssh-key)) + ;; Generate a user SSH key pair for the host to use when offloading + ;; to the guest. + (mkdir-p (dirname offloading-ssh-key)) + (invoke #$(file-append openssh "/bin/ssh-keygen") + "-t" "ed25519" "-N" "" + "-f" offloading-ssh-key) + + ;; Authorize it in the guest for user 'offloading'. + (let ((authorizations + (string-append ssh-directory + "/authorized_keys.d/offloading"))) + (mkdir-p (dirname authorizations)) + (copy-file (string-append offloading-ssh-key ".pub") + authorizations) + (chmod (dirname authorizations) #o555))) + + (unless (file-exists? guix-directory) + (invoke #$(initialize-build-vm-substitutes) + guix-directory)) + + (when #$offloading? + ;; Authorize the archive signing key from GUIX-DIRECTORY in the host. + (invoke #$(authorize-guest-substitutes-on-host) guix-directory))))) + +(define (virtual-build-machine-offloading-ssh-key config) + "Return the name of the file containing the SSH key of user 'offloading'." + (string-append "/etc/guix/offload/ssh/virtual-build-machine/" + (symbol->string + (virtual-build-machine-name config)))) + +(define (virtual-build-machine-activation config) + "Return a gexp to activate the build VM according to CONFIG." + (build-vm-activation (virtual-build-machine-secret-root config) + #:offloading? #t + #:offloading-ssh-key + (virtual-build-machine-offloading-ssh-key config))) + +(define (virtual-build-machine-secret-root config) + (string-append "/etc/guix/virtual-build-machines/" + (symbol->string + (virtual-build-machine-name config)))) + +(define (check-vm-availability config) + "Return a Scheme file that evaluates to true if the service corresponding to +CONFIG, a <virtual-build-machine>, is up and running." + (define service-name + (virtual-build-machine-name config)) + + (scheme-file "check-build-vm-availability.scm" + #~(begin + (use-modules (gnu services herd) + (srfi srfi-34)) + + (guard (c ((service-not-found-error? c) #f)) + (->bool (live-service-running + (current-service '#$service-name))))))) + +(define (build-vm-guix-extension config) + (define vm-ssh-key + (string-append + (virtual-build-machine-secret-root config) + "/etc/ssh/ssh_host_ed25519_key.pub")) + + (define host-ssh-key + (virtual-build-machine-offloading-ssh-key config)) + + (guix-extension + (build-machines + (list #~(if (primitive-load #$(check-vm-availability config)) + (list (build-machine + (name "localhost") + (port #$(virtual-build-machine-ssh-port config)) + (systems + '#$(virtual-build-machine-systems config)) + (user "offloading") + (host-key (call-with-input-file #$vm-ssh-key + (@ (ice-9 textual-ports) + get-string-all))) + (private-key #$host-ssh-key))) + '()))))) + +(define virtual-build-machine-service-type + (service-type + (name 'build-vm) + (extensions (list (service-extension shepherd-root-service-type + build-vm-shepherd-services) + (service-extension guix-service-type + build-vm-guix-extension) + (service-extension account-service-type + virtual-build-machine-accounts) + (service-extension activation-service-type + virtual-build-machine-activation))) + (description + "Create a @dfn{virtual build machine}: a virtual machine (VM) that builds +can be offloaded to. By default, the virtual machine starts with a clock +running at some point in the past.") + (default-value (virtual-build-machine)))) + + +;;; ;;; The Hurd in VM service: a Childhurd. ;;; @@ -1243,24 +1750,26 @@ is added to the OS specified in CONFIG." (source-module-closure '((gnu build secret-service) (guix build utils))) #~(lambda () - (let ((pid (fork+exec-command #$vm-command - #:user "childhurd" - ;; XXX TODO: use "childhurd" after - ;; updating Shepherd - #:group "kvm" - #:environment-variables - ;; QEMU tries to write to /var/tmp - ;; by default. - '("TMPDIR=/tmp"))) - (port #$(hurd-vm-port config %hurd-vm-secrets-port)) - (root #$(hurd-vm-configuration-secret-root config))) + (let* ((pid (fork+exec-command #$vm-command + #:user "childhurd" + ;; XXX TODO: use "childhurd" after + ;; updating Shepherd + #:group "kvm" + #:environment-variables + ;; QEMU tries to write to /var/tmp + ;; by default. + '("TMPDIR=/tmp"))) + (port #$(hurd-vm-port config %hurd-vm-secrets-port)) + (root #$(hurd-vm-configuration-secret-root config)) + (address (make-socket-address AF_INET INADDR_LOOPBACK + port))) (catch #t (lambda _ ;; XXX: 'secret-service-send-secrets' won't complete until ;; the guest has booted and its secret service server is ;; running, which could take 20+ seconds during which PID 1 ;; is stuck waiting. - (if (secret-service-send-secrets port root) + (if (secret-service-send-secrets address root) pid (begin (kill (- pid) SIGTERM) @@ -1284,136 +1793,13 @@ is added to the OS specified in CONFIG." (shell (file-append shadow "/sbin/nologin")) (system? #t)))) -(define (initialize-hurd-vm-substitutes) - "Initialize the Hurd VM's key pair and ACL and store it on the host." - (define run - (with-imported-modules '((guix build utils)) - #~(begin - (use-modules (guix build utils) - (ice-9 match)) - - (define host-key - "/etc/guix/signing-key.pub") - - (define host-acl - "/etc/guix/acl") - - (match (command-line) - ((_ guest-config-directory) - (setenv "GUIX_CONFIGURATION_DIRECTORY" - guest-config-directory) - (invoke #+(file-append guix "/bin/guix") "archive" - "--generate-key") - - (when (file-exists? host-acl) - ;; Copy the host ACL. - (copy-file host-acl - (string-append guest-config-directory - "/acl"))) - - (when (file-exists? host-key) - ;; Add the host key to the childhurd's ACL. - (let ((key (open-fdes host-key O_RDONLY))) - (close-fdes 0) - (dup2 key 0) - (execl #+(file-append guix "/bin/guix") - "guix" "archive" "--authorize")))))))) - - (program-file "initialize-hurd-vm-substitutes" run)) - -(define (authorize-guest-substitutes-on-host) - "Return a program that authorizes the guest's archive signing key (passed as -an argument) on the host." - (define not-config? - (match-lambda - ('(guix config) #f) - (('guix _ ...) #t) - (('gnu _ ...) #t) - (_ #f))) - - (define run - (with-extensions (list guile-gcrypt) - (with-imported-modules `(((guix config) => ,(make-config.scm)) - ,@(source-module-closure - '((guix pki) - (guix build utils)) - #:select? not-config?)) - #~(begin - (use-modules (ice-9 match) - (ice-9 textual-ports) - (gcrypt pk-crypto) - (guix pki) - (guix build utils)) - - (match (command-line) - ((_ guest-config-directory) - (let ((guest-key (string-append guest-config-directory - "/signing-key.pub"))) - (if (file-exists? guest-key) - ;; Add guest key to the host's ACL. - (let* ((key (string->canonical-sexp - (call-with-input-file guest-key - get-string-all))) - (acl (public-keys->acl - (cons key (acl->public-keys (current-acl)))))) - (with-atomic-file-replacement %acl-file - (lambda (_ port) - (write-acl acl port)))) - (format (current-error-port) - "warning: guest key missing from '~a'~%" - guest-key))))))))) - - (program-file "authorize-guest-substitutes-on-host" run)) - (define (hurd-vm-activation config) "Return a gexp to activate the Hurd VM according to CONFIG." - (with-imported-modules '((guix build utils)) - #~(begin - (use-modules (guix build utils)) - - (define secret-directory - #$(hurd-vm-configuration-secret-root config)) - - (define ssh-directory - (string-append secret-directory "/etc/ssh")) - - (define guix-directory - (string-append secret-directory "/etc/guix")) - - (define offloading-ssh-key - #$(hurd-vm-configuration-offloading-ssh-key config)) - - (unless (file-exists? ssh-directory) - ;; Generate SSH host keys under SSH-DIRECTORY. - (mkdir-p ssh-directory) - (invoke #$(file-append openssh "/bin/ssh-keygen") - "-A" "-f" secret-directory)) - - (unless (or (not #$(hurd-vm-configuration-offloading? config)) - (file-exists? offloading-ssh-key)) - ;; Generate a user SSH key pair for the host to use when offloading - ;; to the guest. - (mkdir-p (dirname offloading-ssh-key)) - (invoke #$(file-append openssh "/bin/ssh-keygen") - "-t" "ed25519" "-N" "" - "-f" offloading-ssh-key) - - ;; Authorize it in the guest for user 'offloading'. - (let ((authorizations - (string-append ssh-directory - "/authorized_keys.d/offloading"))) - (mkdir-p (dirname authorizations)) - (copy-file (string-append offloading-ssh-key ".pub") - authorizations) - (chmod (dirname authorizations) #o555))) - - (unless (file-exists? guix-directory) - (invoke #$(initialize-hurd-vm-substitutes) - guix-directory)) - - (when #$(hurd-vm-configuration-offloading? config) - ;; Authorize the archive signing key from GUIX-DIRECTORY in the host. - (invoke #$(authorize-guest-substitutes-on-host) guix-directory))))) + (build-vm-activation (hurd-vm-configuration-secret-root config) + #:offloading? + (hurd-vm-configuration-offloading? config) + #:offloading-ssh-key + (hurd-vm-configuration-offloading-ssh-key config))) (define (hurd-vm-configuration-offloading-ssh-key config) "Return the name of the file containing the SSH key of user 'offloading'." diff --git a/gnu/services/web.scm b/gnu/services/web.scm index 05fd71f994..406117c457 100644 --- a/gnu/services/web.scm +++ b/gnu/services/web.scm @@ -16,6 +16,7 @@ ;;; Copyright © 2020, 2021 Alexandru-Sergiu Marton <brown121407@posteo.ro> ;;; Copyright © 2022 Simen Endsjø <simendsjo@gmail.com> ;;; Copyright © 2023 Bruno Victal <mirai@makinata.eu> +;;; Copyright © 2023 Miguel Ángel Moreno <mail@migalmoreno.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -36,6 +37,7 @@ #:use-module (gnu services) #:use-module (gnu services shepherd) #:use-module (gnu services admin) + #:use-module (gnu services configuration) #:use-module (gnu services getmail) #:use-module (gnu services mail) #:use-module (gnu system pam) @@ -47,6 +49,7 @@ #:use-module (gnu packages patchutils) #:use-module (gnu packages php) #:use-module (gnu packages python) + #:use-module (gnu packages python-web) #:use-module (gnu packages gnupg) #:use-module (gnu packages guile) #:use-module (gnu packages logging) @@ -240,6 +243,13 @@ varnish-service-type + whoogle-service-type + whoogle-configuration + whoogle-configuration-package + whoogle-configuration-host + whoogle-configuration-port + whoogle-configuration-environment-variables + patchwork-database-configuration patchwork-database-configuration? patchwork-database-configuration-engine @@ -1605,6 +1615,52 @@ files.") ;;; +;;; Whoogle +;;; + +(define-configuration/no-serialization whoogle-configuration + (package + (package whoogle-search) + "The @code{whoogle-search} package to use.") + (host + (string "127.0.0.1") + "The host address to run Whoogle on.") + (port + (integer 5000) + "The port to run Whoogle on.") + (environment-variables + (list-of-strings '()) + "A list of strings specifying environment variables used to configure +Whoogle.")) + +(define (whoogle-shepherd-service config) + (match-record config <whoogle-configuration> + (package host port environment-variables) + (list + (shepherd-service + (provision '(whoogle-search)) + (start #~(make-forkexec-constructor + (list (string-append #$package "/bin/whoogle-search") + "--host" #$host "--port" #$(number->string port)) + #:environment-variables + (append (list "CONFIG_VOLUME=/var/cache/whoogle-search") + '#$environment-variables))) + (stop #~(make-kill-destructor)) + (documentation "Run a @code{whoogle-search} instance."))))) + +(define whoogle-service-type + (service-type + (name 'whoogle-search) + (extensions + (list (service-extension shepherd-root-service-type + whoogle-shepherd-service) + (service-extension profile-service-type + (compose list whoogle-configuration-package)))) + (default-value (whoogle-configuration)) + (description "Set up the @code{whoogle-search} metasearch engine."))) + + +;;; ;;; Patchwork ;;; |