aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020, 2023 Janneke Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu build hurd-boot)
  #:use-module (system repl error-handling)
  #:autoload   (system repl repl) (start-repl)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:use-module (guix build utils)
  #:use-module ((guix build syscalls)
                #:hide (file-system-type))
  #:export (make-hurd-device-nodes
            boot-hurd-system))

;;; Commentary:
;;;
;;; Utility procedures useful to boot a Hurd system.
;;;
;;; Code:

;; XXX FIXME c&p from linux-boot.scm
(define (find-long-option option arguments)
  "Find OPTION among ARGUMENTS, where OPTION is something like \"--load\".
Return the value associated with OPTION, or #f on failure."
  (let ((opt (string-append option "=")))
    (and=> (find (cut string-prefix? opt <>)
                 arguments)
           (lambda (arg)
             (substring arg (+ 1 (string-index arg #\=)))))))

;; XXX FIXME c&p from guix/utils.scm
(define (readlink* file)
  "Call 'readlink' until the result is not a symlink."
  (define %max-symlink-depth 50)

  (let loop ((file  file)
             (depth 0))
    (define (absolute target)
      (if (absolute-file-name? target)
          target
          (string-append (dirname file) "/" target)))

    (if (>= depth %max-symlink-depth)
        file
        (call-with-values
            (lambda ()
              (catch 'system-error
                (lambda ()
                  (values #t (readlink file)))
                (lambda args
                  (let ((errno (system-error-errno args)))
                    (if (or (= errno EINVAL))
                        (values #f file)
                        (apply throw args))))))
          (lambda (success? target)
            (if success?
                (loop (absolute target) (+ depth 1))
                file))))))

(define* (make-hurd-device-nodes #:optional (root "/"))
  "Make some of the nodes needed on GNU/Hurd."
  (define (scope dir)
    (string-append root (if (string-suffix? "/" root) "" "/") dir))

  (mkdir-p (scope "dev"))
  ;; Don't create /dev/null etc just yet; the store
  ;; messes-up the permission bits.
  ;; Don't create /dev/console, /dev/vcs, etc.: they are created by
  ;; console-run on first boot.

  (mkdir-p (scope "servers"))
  (for-each (lambda (file)
              (call-with-output-file (scope (string-append "servers/" file))
                (lambda (port)
                  (display file port)   ;avoid hard-linking
                  (chmod port #o444))))
            '("startup"
              "exec"
              "proc"
              "password"
              "default-pager"
              "crash-dump-core"
              "kill"
              "suspend"))

  (mkdir-p (scope "servers/socket"))

  ;; Don't create /servers/socket/1 & co: runsystem does that on first boot.

  ;; TODO: Set the 'gnu.translator' extended attribute for passive translator
  ;; settings?
  (mkdir-p (scope "servers/bus/pci")))

(define (passive-translator-xattr? file-name)
  "Return true if FILE-NAME has an extended @code{gnu.translator} attribute
set."
  (catch 'system-error
    (lambda _ (not (string-null? (getxattr file-name "gnu.translator"))))
    (lambda args
      (if (= ENODATA (system-error-errno args))
          #f
          (apply throw args)))))

(define (passive-translator-installed? file-name)
  "Return true if @file{showtrans} finds a translator installed on FILE-NAME."
  (with-output-to-port (%make-void-port "w")
    (lambda _
      (with-error-to-port (%make-void-port "w")
        (lambda _
          (zero? (system* "showtrans" "--silent" file-name)))))))

(define (translated? file-name)
  "Return true if a translator is installed on FILE-NAME."
  ;; On GNU/Hurd, 'getxattr' in glibc opens the file without O_NOTRANS, and
  ;; then, for "gnu.translator", it calls 'file_get_translator', resulting in
  ;; EOPNOTSUPP (conversely, 'showtrans' opens the file with O_NOTRANS).
  (if (string-contains %host-type "linux-gnu")
      (passive-translator-xattr? file-name)
      (passive-translator-installed? file-name)))

(define* (set-translator file-name command #:optional (mode #o600))
  "Setup translator COMMAND on FILE-NAME."
  (unless (translated? file-name)
    (let ((dir (dirname file-name)))
      (unless (directory-exists? dir)
        (mkdir-p dir))
      (unless (file-exists? file-name)
        (call-with-output-file file-name
          (lambda (port)
            (display file-name port)  ;avoid hard-linking
            (chmod port mode)))))
    (catch 'system-error
      (lambda _
        (setxattr file-name "gnu.translator" (string-join command "\0" 'suffix)))
      (lambda (key . args)
        (let ((errno (system-error-errno (cons key args))))
          (format (current-error-port) "~a: ~a\n"
                  (strerror errno) file-name)
          (format (current-error-port) "Ignoring...Good Luck!\n"))))))

(define-syntax-rule (false-if-EEXIST exp)
  "Evaluate EXP but return #f if it raises to 'system-error with EEXIST."
  (catch 'system-error
    (lambda () exp)
    (lambda args
      (if (= EEXIST (system-error-errno args))
          #f
          (apply throw args)))))

(define* (set-hurd-device-translators #:optional (root "/"))
  "Make some of the device nodes needed on GNU/Hurd."

  (define (scope dir)
    (string-append root (if (string-suffix? "/" root) "" "/") dir))

  (define scope-set-translator
    (match-lambda
      ((file-name command)
       (scope-set-translator (list file-name command #o600)))
      ((file-name command mode)
       (let ((mount-point (scope file-name)))
         (set-translator mount-point command mode)))))

  (define (mkdir* dir)
    (let ((dir (scope dir)))
     (unless (file-exists? dir)
       (mkdir-p dir))))

  (define servers
    '(("servers/bus/pci"         ("/hurd/pci-arbiter"))
      ("servers/crash-dump-core" ("/hurd/crash" "--dump-core"))
      ("servers/crash-kill"      ("/hurd/crash" "--kill"))
      ("servers/crash-suspend"   ("/hurd/crash" "--suspend"))
      ("servers/password"        ("/hurd/password"))
      ("servers/socket/1"        ("/hurd/pflocal"))
      ;; /servers/socket/2 and /26 are created by 'static-networking-service'.
      ;; XXX: Spawn pfinet without arguments on these nodes so that a DHCP
      ;; client has someone to talk to?
      ("proc"                    ("/hurd/procfs" "--stat-mode=444"))))

  (define devices
    `(("dev/full"    ("/hurd/null"     "--full")            #o666)
      ("dev/null"    ("/hurd/null")                         #o666)
      ("dev/random"  ("/hurd/random"   "--seed-file" "/var/lib/random-seed")
                                                            #o644)
      ("dev/zero"    ("/hurd/storeio"  "--store-type=zero") #o666)

      ("dev/console" ("/hurd/term"     "/dev/console" "device" "console"))

      ("dev/klog"    ("/hurd/streamio" "kmsg"))
      ("dev/mem"     ("/hurd/storeio"  "--no-cache" "mem")  #o660)
      ("dev/shm"     ("/hurd/tmpfs"    "--mode=1777" "50%") #o644)
      ("dev/time"    ("/hurd/storeio"  "--no-cache" "time") #o644)

      ("dev/vcs"     ("/hurd/console"))
      ("dev/tty"     ("/hurd/magic"    "tty")               #o666)

      ;; 'fd_to_filename' in libc expects it.
      ("dev/fd"      ("/hurd/magic"    "--directory" "fd")  #o555)

      ("dev/rumpdisk" ("/hurd/rumpdisk")                    #o660)
      ("dev/netdde"  ("/hurd/netdde")                       #o660)
      ("dev/eth0"    ("/hurd/devnode" "--master-device=/dev/net"
                      "eth0")
                                                            #o660)
      ("dev/eth1"    ("/hurd/devnode" "--master-device=/dev/net"
                      "eth1")
                                                            #o660)

      ;; Create a number of ttys; syslogd writes to tty12 by default.
      ;; FIXME: Creating /dev/tty12 leads the console client to switch to
      ;; tty12 when syslogd starts, which is confusing for users.  Thus, do
      ;; not create tty12.
      ,@(map (lambda (n)
               (let ((n (number->string n)))
                 `(,(string-append "dev/tty" n)
                   ("/hurd/term" ,(string-append "/dev/tty" n)
                    "hurdio" ,(string-append "/dev/vcs/" n "/console"))
                   #o666)))
             (iota 11 1))

      ,@(append-map (lambda (n)
                      (let ((n (number->string n)))
                        `((,(string-append "dev/ptyp" n)
                           ("/hurd/term" ,(string-append "/dev/ptyp" n)
                            "pty-master" ,(string-append "/dev/ttyp" n))
                           #o666)

                          (,(string-append "dev/ttyp" n)
                           ("/hurd/term" ,(string-append "/dev/ttyp" n)
                            "pty-slave" ,(string-append "/dev/ptyp" n))
                           #o666))))
                    (iota 10 0))
      ,@(append-map (lambda (n)
                      (let* ((n (number->string n))
                             (disk (string-append "hd" n))
                             (drive (string-append "dev/" disk)))
                        `((,drive ("/hurd/storeio" ,disk) #o600)
                          ,@(map (lambda (p)
                                   (let ((p (number->string p)))
                                     `(,(string-append drive "s" p)
                                       ("/hurd/storeio"
                                        ,(string-append disk "s" p))
                                       #o660)))
                                 (iota 4 1)))))
                    (iota 4 0))
      ,@(append-map (lambda (n)
                      (let* ((n (number->string n))
                             (drive (string-append "dev/wd" n))
                             (disk (string-append "@/dev/disk:wd" n)))
                        `((,drive ("/hurd/storeio" ,disk) #o600)
                          ,@(map (lambda (p)
                                   (let ((p (number->string p)))
                                     `(,(string-append drive "s" p)
                                       ("/hurd/storeio"
                                        "--store-type=typed"
                                        ,(string-append
                                          "part:" p ":device:" disk))
                                       #o660)))
                                 (iota 4 1)))))
                    (iota 4 0))))

  (for-each scope-set-translator servers)
  (mkdir* "dev/vcs/1")
  (mkdir* "dev/vcs/2")
  (when (file-exists? (scope "dev/console"))
    (rename-file (scope "dev/console") (scope "dev/console-")))
  (for-each scope-set-translator devices)

  (false-if-EEXIST (symlink "/dev/random" (scope "dev/urandom")))
  (false-if-EEXIST (symlink "/dev/fd/0" (scope "dev/stdin")))
  (false-if-EEXIST (symlink "/dev/fd/1" (scope "dev/stdout")))
  (false-if-EEXIST (symlink "/dev/fd/2" (scope "dev/stderr")))
  (false-if-EEXIST (symlink "crash-dump-core" (scope "servers/crash")))
  (false-if-EEXIST (symlink "/dev/rumpdisk" (scope "dev/disk")))
  (false-if-EEXIST (symlink "/dev/netdde" (scope "dev/net")))
  (false-if-EEXIST (symlink "/servers/socket/2" (scope "servers/socket/inet")))
  (false-if-EEXIST (symlink "/servers/socket/26" (scope "servers/socket/inet6")))

  ;; Make sure /etc/mtab is a symlink to /proc/mounts.
  (false-if-exception (delete-file (scope "etc/mtab")))
  (mkdir* (scope "etc"))
  (symlink "/proc/mounts" (scope "etc/mtab")))


(define* (boot-hurd-system #:key (on-error 'debug))
  "This procedure is meant to be called from an early RC script.

Install the relevant passive translators on the first boot.  Then, run system
activation by using the kernel command-line options 'gnu.system' and 'gnu.load';
starting the Shepherd.

XXX TODO: see linux-boot.scm:boot-system.
XXX TODO: add proper file-system checking, mounting
XXX TODO: move bits to (new?) (hurd?) (activation?) services
XXX TODO: use Linux xattr/setxattr to remove (settrans in) /libexec/RUNSYSTEM

"

  (display "Welcome, this is GNU's early boot Guile.\n")
  (display "Use 'gnu.repl' for an initrd REPL.\n\n")

  (call-with-error-handling
   (lambda ()

     (let* ((args    (command-line))
            (system  (find-long-option "gnu.system" args))
            (to-load (find-long-option "gnu.load" args))
            (profile (string-append system "/profile"))
            (bin     (string-append profile "/bin"))
            (sbin    (string-append profile "/bin")))

       (setenv "PATH" (string-append bin ":" sbin))

       (when (file-exists? "/var/run/shepherd/socket")
         (format #t "Removing stale shepherd socket...\n")
         (delete-file "/var/run/shepherd/socket"))

       (unless (file-exists? "/servers/startup")
         (format #t "Creating essential device nodes...\n")
         (make-hurd-device-nodes))

       (let ((profile/hurd (readlink* (string-append profile "/hurd"))))
         (when (file-exists? "/hurd")
           (format #t "Removing stale /hurd link\n")
           (delete-file "/hurd"))
         (format #t "Linking /hurd from ~a...\n" profile/hurd)
         (symlink profile/hurd "/hurd"))

       (format #t "Setting-up essential translators...\n")
       (set-hurd-device-translators)

       (format #t "Starting pager...\n")
       (unless (zero? (system* "/hurd/mach-defpager"))
         (format #t "FAILED...Good luck!\n"))

       (cond ((member "gnu.repl" args)
              (format #t "Starting repl...\n")
              (start-repl))
             (to-load
              (format #t "loading '~a'...\n" to-load)
              (primitive-load to-load)
              (format (current-error-port)
                      "boot program '~a' terminated, rebooting~%"
                      to-load)
              (sleep 2)
              (reboot))
             (else
              (display "no boot file passed via 'gnu.load'\n")
              (display "entering a warm and cozy REPL\n")
              (start-repl)))))
   #:on-error on-error))

;;; hurd-boot.scm ends here
generated by cgit
ganeti-luxid-configuration-debug? ;Boolean (default #f))) (define ganeti-luxid-service (match-lambda (($ <ganeti-luxid-configuration> ganeti no-voting? debug?) (list (shepherd-service (documentation "Run the Ganeti LUXI daemon.") (provision '(ganeti-luxid)) (requirement '(user-processes)) ;; This service will automatically disable itself when not ;; running on the master node. Don't attempt to restart it. (respawn? #f) (start #~(make-forkexec-constructor (list #$(file-append ganeti "/sbin/ganeti-luxid") #$@(if no-voting? #~("--no-voting" "--yes-do-it") #~()) #$@(if debug? #~("--debug") #~())) #:environment-variables '#$%default-ganeti-environment-variables #:pid-file "/var/run/ganeti/ganeti-luxid.pid")) (stop #~(make-kill-destructor))))))) (define ganeti-luxid-service-type (service-type (name 'ganeti-luxid) (extensions (list (service-extension shepherd-root-service-type ganeti-luxid-service))) (default-value (ganeti-luxid-configuration)) (description "@command{ganeti-luxid} is a daemon used to answer queries related to the configuration and the current live state of a Ganeti cluster. Additionally, it is the authoritative daemon for the Ganeti job queue. Jobs can be submitted via this daemon and it schedules and starts them."))) (define-record-type* <ganeti-rapi-configuration> ganeti-rapi-configuration make-ganeti-rapi-configuration ganeti-rapi-configuration? (ganeti ganeti-rapi-configuration-ganeti ;file-like (default ganeti)) (require-authentication? ganeti-rapi-configuration-require-authentication? ;Boolean (default #f)) (port ganeti-rapi-configuration-port ;integer (default 5080)) (address ganeti-rapi-configuration-address ;string (default "0.0.0.0")) (interface ganeti-rapi-configuration-interface ;string | #f (default #f)) (max-clients ganeti-rapi-configuration-max-clients ;integer (default 20)) (ssl? ganeti-rapi-configuration-ssl? ;Boolean (default #t)) (ssl-key ganeti-rapi-configuration-ssl-key ;string (default "/var/lib/ganeti/server.pem")) (ssl-cert ganeti-rapi-configuration-ssl-cert ;string (default "/var/lib/ganeti/server.pem")) (debug? ganeti-rapi-configuration-debug? ;Boolean (default #f))) (define ganeti-rapi-service (match-lambda (($ <ganeti-rapi-configuration> ganeti require-authentication? port address interface max-clients ssl? ssl-key ssl-cert debug?) (list (shepherd-service (documentation "Run the Ganeti RAPI daemon.") (provision '(ganeti-rapi)) (requirement '(user-processes networking)) ;; This service will automatically disable itself when not ;; running on the master node. Don't attempt to restart it. (respawn? #f) (start #~(make-forkexec-constructor (list #$(file-append ganeti "/sbin/ganeti-rapi") #$@(if require-authentication? #~("--require-authentication") #~()) #$(string-append "--port=" (number->string port)) #$(string-append "--bind=" address) #$@(if interface #~((string-append "--interface=" #$interface)) #~()) #$(string-append "--max-clients=" (number->string max-clients)) #$@(if ssl? #~((string-append "--ssl-key=" #$ssl-key) (string-append "--ssl-cert=" #$ssl-cert)) #~("--no-ssl")) #$@(if debug? #~("--debug") #~())) #:environment-variables '#$%default-ganeti-environment-variables #:pid-file "/var/run/ganeti/ganeti-rapi.pid")) (stop #~(make-kill-destructor))))))) (define ganeti-rapi-service-type (service-type (name 'ganeti-rapi) (extensions (list (service-extension shepherd-root-service-type ganeti-rapi-service))) (default-value (ganeti-rapi-configuration)) (description "@command{ganeti-rapi} is the daemon providing a remote API for Ganeti clusters."))) (define-record-type* <ganeti-kvmd-configuration> ganeti-kvmd-configuration make-ganeti-kvmd-configuration ganeti-kvmd-configuration? (ganeti ganeti-kvmd-configuration-ganeti ;file-like (default ganeti)) (debug? ganeti-kvmd-configuration-debug? ;Boolean (default #f))) (define ganeti-kvmd-service (match-lambda (($ <ganeti-kvmd-configuration> ganeti debug?) (list (shepherd-service (documentation "Run the Ganeti KVM daemon.") (provision '(ganeti-kvmd)) (requirement '(user-processes)) ;; This service will automatically disable itself when not ;; needed. Don't attempt to restart it. (respawn? #f) (start #~(make-forkexec-constructor (list #$(file-append ganeti "/sbin/ganeti-kvmd") #$@(if debug? #~("--debug") #~())) #:environment-variables '#$%default-ganeti-environment-variables #:pid-file "/var/run/ganeti/ganeti-kvmd.pid")) (stop #~(make-kill-destructor))))))) (define ganeti-kvmd-service-type (service-type (name 'ganeti-kvmd) (extensions (list (service-extension shepherd-root-service-type ganeti-kvmd-service))) (default-value (ganeti-kvmd-configuration)) (description "@command{ganeti-kvmd} is responsible for determining whether a given KVM instance was shutdown by an administrator or a user. The KVM daemon monitors, using @code{inotify}, KVM instances through their QMP sockets, which are provided by KVM. Using the QMP sockets, the KVM daemon listens for particular shutdown, powerdown, and stop events which will determine if a given instance was shutdown by the user or Ganeti, and this result is communicated to Ganeti via a special file in the file system."))) (define-record-type* <ganeti-mond-configuration> ganeti-mond-configuration make-ganeti-mond-configuration ganeti-mond-configuration? (ganeti ganeti-mond-configuration-ganeti ;file-like (default ganeti)) (port ganeti-mond-configuration-port ;integer (default 1815)) (address ganeti-mond-configuration-address ;string (default "0.0.0.0")) (debug? ganeti-mond-configuration-debug? ;Boolean (default #f))) (define ganeti-mond-service (match-lambda (($ <ganeti-mond-configuration> ganeti port address debug?) (list (shepherd-service (documentation "Run the Ganeti monitoring daemon.") (provision '(ganeti-mond)) (requirement '(user-processes networking)) (respawn? #f) (start #~(make-forkexec-constructor (list #$(file-append ganeti "/sbin/ganeti-mond") #$(string-append "--port=" (number->string port)) #$(string-append "--bind=" address) #$@(if debug? #~("--debug") #~())) #:pid-file "/var/run/ganeti/ganeti-mond.pid")) (stop #~(make-kill-destructor))))))) (define ganeti-mond-service-type (service-type (name 'ganeti-mond) (extensions (list (service-extension shepherd-root-service-type ganeti-mond-service))) (default-value (ganeti-mond-configuration)) (description "@command{ganeti-mond} is a daemon providing monitoring functionality. It is responsible for running the data collectors and to provide the collected information through a HTTP interface."))) (define-record-type* <ganeti-metad-configuration> ganeti-metad-configuration make-ganeti-metad-configuration ganeti-metad-configuration? (ganeti ganeti-metad-configuration-ganeti ;file-like (default ganeti)) (port ganeti-metad-configuration-port ;integer (default 80)) (address ganeti-metad-configuration-address ;string | #f (default #f)) (debug? ganeti-metad-configuration-debug? ;Boolean (default #f))) (define ganeti-metad-service (match-lambda (($ <ganeti-metad-configuration> ganeti port address debug?) (list (shepherd-service (documentation "Run the Ganeti metadata daemon.") (provision '(ganeti-metad)) (requirement '(user-processes networking)) ;; This service is started on demand. (auto-start? #f) (respawn? #f) (start #~(make-forkexec-constructor (list #$(file-append ganeti "/sbin/ganeti-metad") #$(string-append "--port=" (number->string port)) #$@(if address #~((string-append "--bind=" #$address)) #~()) #$@(if debug? #~("--debug") #~())) #:pid-file "/var/run/ganeti/ganeti-metad.pid")) (stop #~(make-kill-destructor))))))) (define ganeti-metad-service-type (service-type (name 'ganeti-metad) (extensions (list (service-extension shepherd-root-service-type ganeti-metad-service))) (default-value (ganeti-metad-configuration)) (description "@command{ganeti-metad} is a daemon that can be used to pass information to OS install scripts or instances."))) (define-record-type* <ganeti-watcher-configuration> ganeti-watcher-configuration make-ganeti-watcher-configuration ganeti-watcher-configuration? (ganeti ganeti-watcher-configuration-ganeti ;file-like (default ganeti)) (schedule ganeti-watcher-configuration-schedule ;list | string (default '(next-second-from ;; Run every five minutes. (next-minute (range 0 60 5))))) (rapi-ip ganeti-watcher-configuration-rapi-ip ;#f | string (default #f)) (job-age ganeti-watcher-configuration-job-age ;integer (default (* 6 3600))) (verify-disks? ganeti-watcher-configuration-verify-disks? ;Boolean (default #t)) (debug? ganeti-watcher-configuration-debug? ;Boolean (default #f))) (define ganeti-watcher-command (match-lambda (($ <ganeti-watcher-configuration> ganeti _ rapi-ip job-age verify-disks? debug?) #~(lambda () (system* #$(file-append ganeti "/sbin/ganeti-watcher") #$@(if rapi-ip #~((string-append "--rapi-ip=" #$rapi-ip)) #~()) #$(string-append "--job-age=" (number->string job-age)) #$@(if verify-disks? #~() #~("--no-verify-disks")) #$@(if debug? #~("--debug") #~())))))) (define (ganeti-watcher-jobs config) (match config (($ <ganeti-watcher-configuration> _ schedule) (list #~(job #$@(match schedule ((? string?) #~(#$schedule)) ((? list?) #~('#$schedule))) #$(ganeti-watcher-command config) "ganeti-watcher"))))) (define ganeti-watcher-service-type (service-type (name 'ganeti-watcher) (extensions (list (service-extension mcron-service-type ganeti-watcher-jobs))) (default-value (ganeti-watcher-configuration)) (description "@command{ganeti-watcher} is a periodically run script that performs a number of maintenance actions on the cluster. It will automatically restart instances that are marked as ERROR_down, i.e., instances that should be running, but are not; and it will also try to repair DRBD links in case a secondary node has rebooted. In addition it is responsible for archiving old cluster jobs, and it will restart any down Ganeti daemons that are appropriate for the current node. If the cluster parameter @code{maintain_node_health} is enabled, the watcher will also shutdown instances and DRBD devices if the node is declared offline by known master candidates."))) (define-record-type* <ganeti-cleaner-configuration> ganeti-cleaner-configuration make-ganeti-cleaner-configuration ganeti-cleaner-configuration? (ganeti ganeti-cleaner-configuration-ganeti ;file-like (default ganeti)) (master-schedule ganeti-cleaner-configuration-master-schedule ;list | string ;; Run the master cleaner at 01:45 every day. (default "45 1 * * *")) (node-schedule ganeti-cleaner-configuration-node-schedule ;list | string ;; Run the node cleaner at 02:45 every day. (default "45 2 * * *"))) (define ganeti-cleaner-jobs (match-lambda (($ <ganeti-cleaner-configuration> ganeti master-schedule node-schedule) (list #~(job #$@(match master-schedule ((? string?) #~(#$master-schedule)) ((? list?) #~('#$master-schedule))) (lambda () (system* #$(file-append ganeti "/sbin/ganeti-cleaner") "master")) "ganeti master cleaner") #~(job #$@(match node-schedule ((? string?) #~(#$node-schedule)) ((? list?) #~('#$node-schedule))) (lambda () (system* #$(file-append ganeti "/sbin/ganeti-cleaner") "node")) "ganeti node cleaner"))))) (define ganeti-cleaner-service-type (service-type (name 'ganeti-cleaner) (extensions (list (service-extension mcron-service-type ganeti-cleaner-jobs))) (default-value (ganeti-cleaner-configuration)) (description "@command{ganeti-cleaner} is a script that removes old files from the cluster. When called with @code{node} as argument it removes expired X509 certificates and keys from @file{/var/run/ganeti/crypto}, as well as outdated @command{ganeti-watcher} information. When called with @code{master} as argument, it instead removes files older than 21 days from @file{/var/lib/ganeti/queue/archive}."))) (define-record-type* <ganeti-configuration> ganeti-configuration make-ganeti-configuration ganeti-configuration? (ganeti ganeti-configuration-ganeti (default ganeti)) (noded-configuration ganeti-configuration-noded-configuration (default (ganeti-noded-configuration))) (confd-configuration ganeti-configuration-confd-configuration (default (ganeti-confd-configuration))) (wconfd-configuration ganeti-configuration-wconfd-configuration (default (ganeti-wconfd-configuration))) (luxid-configuration ganeti-configuration-luxid-configuration (default (ganeti-luxid-configuration))) (rapi-configuration ganeti-configuration-rapi-configuration (default (ganeti-rapi-configuration))) (kvmd-configuration ganeti-configuration-kvmd-configuration (default (ganeti-kvmd-configuration))) (mond-configuration ganeti-configuration-mond-configuration (default (ganeti-mond-configuration))) (metad-configuration ganeti-configuration-metad-configuration (default (ganeti-metad-configuration))) (watcher-configuration ganeti-configuration-watcher-configuration (default (ganeti-watcher-configuration))) (cleaner-configuration ganeti-configuration-cleaner-configuration (default (ganeti-cleaner-configuration))) (file-storage-paths ganeti-configuration-file-storage-paths ;list of strings | gexp (default '())) (hooks ganeti-configuration-hooks ;<file-like> | #f (default #f)) (os ganeti-configuration-os ;list of <ganeti-os> (default '()))) (define (ganeti-activation config) (with-imported-modules '((guix build utils)) #~(begin (use-modules (guix build utils)) (for-each mkdir-p '("/var/log/ganeti" "/var/log/ganeti/kvm" "/var/log/ganeti/os" "/var/lib/ganeti/rapi" "/var/lib/ganeti/queue" "/var/lib/ganeti/queue/archive" "/var/run/ganeti/bdev-cache" "/var/run/ganeti/crypto" "/var/run/ganeti/socket" "/var/run/ganeti/instance-disks" "/var/run/ganeti/instance-reason" "/var/run/ganeti/livelocks"))))) (define ganeti-shepherd-services (match-lambda (($ <ganeti-configuration> _ noded confd wconfd luxid rapi kvmd mond metad) (append (ganeti-noded-service noded) (ganeti-confd-service confd) (ganeti-wconfd-service wconfd) (ganeti-luxid-service luxid) (ganeti-rapi-service rapi) (ganeti-kvmd-service kvmd) (ganeti-mond-service mond) (ganeti-metad-service metad))))) (define ganeti-mcron-jobs (match-lambda (($ <ganeti-configuration> _ _ _ _ _ _ _ _ _ watcher cleaner) (append (ganeti-watcher-jobs watcher) (ganeti-cleaner-jobs cleaner))))) (define-record-type* <ganeti-os> ganeti-os make-ganeti-os ganeti-os? (name ganeti-os-name) ;string (extension ganeti-os-extension ;#f | string (default #f)) (variants ganeti-os-variants ;<file-like> | list of <ganeti-os-variant> (default '()))) (define-record-type* <ganeti-os-variant> ganeti-os-variant make-ganeti-os-variant ganeti-os-variant? (name ganeti-os-variant-name) ;string (configuration ganeti-os-variant-configuration)) ;<file-like> (define %debootstrap-interfaces-hook (file-append ganeti-instance-debootstrap "/share/doc/ganeti-instance-debootstrap/examples/interfaces")) ;; The GRUB hook shipped with instance-debootstrap does not work with GRUB2. ;; For convenience, provide one that work with modern Debians here. ;; Note: it would be neat to reuse Guix' bootloader infrastructure instead. (define %debootstrap-grub-hook (plain-file "grub" "#!/usr/bin/env bash CLEANUP=( ) cleanup() { if [ ${#CLEANUP[*]} -gt 0 ]; then LAST_ELEMENT=$((${#CLEANUP[*]}-1)) REVERSE_INDEXES=$(seq ${LAST_ELEMENT} -1 0) for i in $REVERSE_INDEXES; do ${CLEANUP[$i]} done fi } trap cleanup EXIT mount -t proc proc $TARGET/proc CLEANUP+=(\"umount $TARGET/proc\") mount -t sysfs sysfs $TARGET/sys CLEANUP+=(\"umount $TARGET/sys\") mount -o bind /dev $TARGET/dev CLEANUP+=(\"umount $TARGET/dev\") echo ' GRUB_TIMEOUT_STYLE=menu GRUB_CMDLINE_LINUX_DEFAULT=\"console=ttyS0,115200 net.ifnames=0\" GRUB_TERMINAL=\"serial\" GRUB_SERIAL_COMMAND=\"serial --unit=0 --speed=115200\" ' >> $TARGET/etc/default/grub # This PATH is propagated into the chroot and necessary to make grub-install # and related commands visible. export PATH=\"/usr/sbin:/usr/bin:/sbin:/bin:$PATH\" chroot \"$TARGET\" grub-install $BLOCKDEV chroot \"$TARGET\" update-grub cleanup trap - EXIT ")) (define %default-debootstrap-hooks `((10-interfaces . ,%debootstrap-interfaces-hook) (90-grub . ,%debootstrap-grub-hook))) (define %default-debootstrap-extra-pkgs ;; Packages suitable for a fully virtualized KVM guest. '("acpi-support-base" "udev" "linux-image-amd64" "openssh-server" "locales-all" "grub-pc")) (define-record-type* <debootstrap-configuration> debootstrap-configuration make-debootstrap-configuration debootstrap-configuration? (hooks debootstrap-configuration-hooks ;#f | gexp | '((name . gexp)) (default %default-debootstrap-hooks)) (proxy debootstrap-configuration-proxy (default #f)) ;#f | string (mirror debootstrap-configuration-mirror ;#f | string (default #f)) (arch debootstrap-configuration-arch (default #f)) ;#f | string (suite debootstrap-configuration-suite ;#f | string (default "stable")) (extra-pkgs debootstrap-configuration-extra-pkgs ;list of strings (default %default-debootstrap-extra-pkgs)) (components debootstrap-configuration-components ;list of strings (default '())) (generate-cache? debootstrap-configuration-generate-cache? ;Boolean (default #t)) (clean-cache debootstrap-configuration-clean-cache ;#f | integer (default 14)) (partition-style debootstrap-configuration-partition-style ;#f | symbol | string (default 'msdos)) (partition-alignment debootstrap-configuration-partition-alignment ;#f | integer (default 2048))) (define (debootstrap-hooks->directory hooks) (match hooks ((? file-like?) hooks) ((? list?) (let ((names (map car hooks)) (files (map cdr hooks))) (with-imported-modules '((guix build utils)) (computed-file "debootstrap-hooks" #~(begin (use-modules (guix build utils) (ice-9 match)) (mkdir-p #$output) (with-directory-excursion #$output (for-each (match-lambda ((name hook) (let ((file-name (string-append #$output "/" (symbol->string name)))) ;; Copy to the destination to ensure ;; the file is executable. (copy-file hook file-name) (chmod file-name #o555)))) '#$(zip names files)))))))) (_ #f))) (define-gexp-compiler (debootstrap-configuration-compiler (file <debootstrap-configuration>) system target) (match file (($ <debootstrap-configuration> hooks proxy mirror arch suite extra-pkgs components generate-cache? clean-cache partition-style partition-alignment) (let ((customize-dir (debootstrap-hooks->directory hooks))) (gexp->derivation "debootstrap-variant" #~(call-with-output-file (ungexp output "out") (lambda (port) (display (string-append (ungexp-splicing `(,@(if proxy `("PROXY=" ,proxy "\n") '()) ,@(if mirror `("MIRROR=" ,mirror "\n") '()) ,@(if arch `("ARCH=" ,arch "\n") '()) ,@(if suite `("SUITE=" ,suite "\n") '()) ,@(if (not (null? extra-pkgs)) `("EXTRA_PKGS=" ,(string-join extra-pkgs ",") "\n") '()) ,@(if (not (null? components)) `("COMPONENTS=" ,(string-join components ",") "\n") '()) ,@(if customize-dir `("CUSTOMIZE_DIR=" ,customize-dir "\n") '()) ,@(if generate-cache? '("GENERATE_CACHE=yes\n") '("GENERATE_CACHE=no\n")) ,@(if clean-cache `("CLEAN_CACHE=" ,(number->string clean-cache) "\n") '()) ,@(if partition-style (if (symbol? partition-style) `("PARTITION_STYLE=" ,(symbol->string partition-style) "\n") `("PARTITION_STYLE=" ,partition-style "\n")) '()) ,@(if partition-alignment `("PARTITION_ALIGNMENT=" ,(number->string partition-alignment) "\n") '())))) port))) #:local-build? #t))))) (define (ganeti-os->directory os) "Return the derivation to build the configuration directory to be installed in /etc/ganeti/instance-$os for OS." (let ((name (ganeti-os-name os)) (extension (ganeti-os-extension os)) (variants (ganeti-os-variants os))) (define builder (with-imported-modules '((guix build utils)) (if (file-like? variants) #~(begin (use-modules (guix build utils)) (mkdir-p #$output) (symlink #$variants (string-append #$output "/variants"))) #~(begin (use-modules (guix build utils) (ice-9 format) (ice-9 match) (srfi srfi-1)) (mkdir-p #$output) (let ((variants-dir (string-append #$output "/variants")) (names '#$(map ganeti-os-variant-name variants)) (configs '#$(map ganeti-os-variant-configuration variants))) (mkdir-p variants-dir) (unless (null? names) (call-with-output-file (string-append variants-dir "/variants.list") (lambda (port) (format port "~a~%" (string-join names "\n")))) (for-each (match-lambda ((name file) (let ((file-name (if #$extension (string-append name #$extension) name))) (symlink file (string-append variants-dir "/" file-name))))) (zip names configs)))))))) (computed-file (string-append name "-os") builder #:local-build? #t))) (define (ganeti-directory file-storage-file hooks os) (let ((dirs (map ganeti-os->directory os)) (names (map ganeti-os-name os))) (define builder #~(begin (use-modules (ice-9 match)) (mkdir #$output) (when #$file-storage-file (symlink #$file-storage-file (string-append #$output "/file-storage-paths"))) (when #$hooks (symlink #$hooks (string-append #$output "/hooks"))) (for-each (match-lambda ((name dest) (symlink dest (string-append #$output "/instance-" name)))) '#$(zip names dirs)))) (computed-file "etc-ganeti" builder))) (define (file-storage-file paths) (match paths ((? null?) #f) ((? list?) (plain-file "file-storage-paths" (string-join paths "\n"))) (_ paths))) (define (ganeti-etc-service config) (list `("ganeti" ,(ganeti-directory (file-storage-file (ganeti-configuration-file-storage-paths config)) (ganeti-configuration-hooks config) (ganeti-configuration-os config))))) (define (debootstrap-os variants) (ganeti-os (name "debootstrap") (extension ".conf") (variants variants))) (define (debootstrap-variant name configuration) (ganeti-os-variant (name name) (configuration configuration))) (define %default-debootstrap-variants (list (debootstrap-variant "default" (debootstrap-configuration)))) (define (guix-os variants) (ganeti-os (name "guix") (extension ".scm") (variants variants))) (define (guix-variant name configuration) (ganeti-os-variant (name name) (configuration configuration))) (define %default-guix-variants (list (guix-variant "default" (file-append ganeti-instance-guix "/share/doc/ganeti-instance-guix/examples/dynamic.scm")))) ;; The OS configurations usually come with a default OS. To make them work ;; out of the box, follow suit. (define %default-ganeti-os (list (debootstrap-os %default-debootstrap-variants) (guix-os %default-guix-variants))) (define ganeti-service-type (service-type (name 'ganeti) (extensions (list (service-extension activation-service-type ganeti-activation) (service-extension shepherd-root-service-type ganeti-shepherd-services) (service-extension etc-service-type ganeti-etc-service) (service-extension profile-service-type (compose list ganeti-configuration-ganeti)) (service-extension mcron-service-type ganeti-mcron-jobs))) (default-value (ganeti-configuration (os %default-ganeti-os))) (description "Ganeti is a family of services that are designed to run on a fleet of machines and facilitate deployment and maintenance of virtual servers (@dfn{instances}). It can migrate instances between nodes, automatically restart failed instances, evacuate nodes, and much more.")))
generated by cgit