From 1e99ee6ff7f47db2052e226d7b071e31ff33b56c Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Wed, 4 Aug 2021 17:09:47 -0700 Subject: add LXC properties, :LXC{,-UNPRIV-ATTACH} connections, WITH-HOMEDIR Signed-off-by: Sean Whitton --- src/property/lxc.lisp | 329 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 329 insertions(+) create mode 100644 src/property/lxc.lisp (limited to 'src/property/lxc.lisp') diff --git a/src/property/lxc.lisp b/src/property/lxc.lisp new file mode 100644 index 0000000..4feb34f --- /dev/null +++ b/src/property/lxc.lisp @@ -0,0 +1,329 @@ +;;; Consfigurator -- Lisp declarative configuration management system + +;;; Copyright (C) 2021 Sean Whitton + +;;; This file 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, or (at your option) +;;; any later version. + +;;; This file 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 this program. If not, see . + +(in-package :consfigurator.property.lxc) +(named-readtables:in-readtable :consfigurator) + +;;;; Properties and combinators + +(defproplist installed :posix () + "Install the LXC userspace tools." + (:desc "LXC installed") + (os:etypecase + (debianlike (apt:installed "lxc")))) + +(defmacro default-maps-params (uid-maps-param gid-maps-param) + `(setq ,uid-maps-param + (or ,uid-maps-param + (list (cons 0 (multiple-value-list + (get-ids-offset user "/etc/subuid"))))) + ,gid-maps-param + (or ,gid-maps-param + (list (cons 0 (multiple-value-list + (get-ids-offset user "/etc/subgid"))))))) + +(defprop user-container-started :posix (host &optional owner) + "Ensure the LXC unprivileged container for the host designated by HOST owned +by OWNER, defaulting to the current user, is started. +(I.e., if HOST is a string, ensure the container named HOST is started; if +HOST is a HOST value, start the container whose name is HOST's hostname.)" + (:desc #?"LXC container ${(get-hostname host)} started") + (:check (or (service:no-services-p) (user-container-active-p host owner))) + (:apply (lxc-cmd owner "lxc-unpriv-start" "-n" (get-hostname host)))) + +(defmacro when-user-container-running ((host &key owner) &body propapps) + "Apply PROPAPPS only when the unprivileged LXC for the host designated by HOST +and owned by OWNER, defaulting to the current user, is already started." + `(when-user-container-running* + ,host ,owner + ,(if (cdr propapps) `(eseqprops ,@propapps) (car propapps)))) + +(define-function-property-combinator + when-user-container-running* (host owner propapp) + (macrolet ((check-running (form) + `(if (user-container-running-p host owner) ,form :no-change))) + (:retprop :type (propapptype propapp) + :desc (get (car propapp) 'desc) + :hostattrs (get (car propapp) 'hostattrs) + :apply (lambda-ignoring-args + (check-running (propappapply propapp))) + :unapply (lambda-ignoring-args + (check-running (propappunapply propapp))) + :args (cdr propapp)))) + +(defproplist user-containers-autostart :posix (user) + "Install a systemd user unit for USER to autostart all LXC user containers +owned by that user which have lxc.start.auto turned on. Also ensures that +lingering is enabled for USER, so the user unit triggers at system boot. + +A limitation of the current implementation is that it assumes XDG_CONFIG_HOME +is ~/.config." + (:desc #?"LXC autostart systemd user unit installed for ${user}") + (user:has-account user) + (systemd:lingering-enabled user) + (as user + (file:directory-exists ".config/systemd/user") + (file:has-content ".config/systemd/user/lxc-autostart.service" + '("[Unit]" + "Description=\"lxc-autostart\"" + + "[Service]" + "Type=oneshot" + "Delegate=yes" + "ExecStart=/usr/bin/lxc-autostart" + "ExecStop=/usr/bin/lxc-autostart --shutdown" + "RemainAfterExit=yes" + + "[Install]" + "WantedBy=default.target")) + (systemd:enabled "lxc-autostart" t))) + +(defprop usernet-usable-by :posix + (user &optional (interface "lxcbr0") (count 10)) + "Ensure that USER is allowed to attach up to COUNT unprivileged LXCs to the +LXC-managed bridge INTERFACE. + +As a special case, INTERFACE may also be \"none\", which gives USER permission +to create veth pairs where the peer outside the container is not attached to +any bridge." + (:desc #?"${user} may attach LXC veth devices to ${interface}") + (:apply (file:map-file-lines + "/etc/lxc/lxc-usernet" + (lambda (lines) + (loop with done + and want = (format nil "~A veth ~A ~D" user interface count) + and prefix = (strcat user " veth " interface) + for line in lines + if (string-prefix-p prefix line) + unless done collect want into accum and do (setq done t) + end + else collect line into accum + finally (return + (if done accum (nconc accum (list want))))))))) + +(defprop %ids-shifted-for :lisp + (user directory uid-maps gid-maps + &optional + (rootfs + (merge-pathnames "rootfs/" + (ensure-directory-pathname directory)))) + "Recursively shift the user and group ownership of ROOTFS according to +UID-MAPS and GID-MAPS and chown DIRECTORY to root's UID according to UID-MAPS. +Not idempotent! Also set the mode of DIRECTORY to 0770, as is standard for +unprivileged LXCs." + (:apply + (default-maps-params uid-maps gid-maps) + (let ((dir (ensure-directory-pathname directory)) + (uidmap (reduce-id-maps uid-maps)) + (gidmap (reduce-id-maps gid-maps))) + (handler-bind ((serious-condition + ;; Don't leave a partially-shifted tree. + (lambda-ignoring-args (delete-remote-trees rootfs)))) + (shift-ids rootfs uidmap gidmap)) + ;; Don't see how to pass (gid_t)-1 as the third argument via CFFI. Note + ;; that gid_t is not guaranteed to be unsigned. + (nix:chown dir (funcall uidmap 0) (nix:stat-gid (nix:stat dir))) + (nix:chmod dir #o770)))) + +(defprop %container-config-populated :posix + (prelude-lines user uid-maps gid-maps directory autostart hostname + additional-lines) + (:apply + (default-maps-params uid-maps gid-maps) + (let ((uid-maps (loop for (inside outside count) in uid-maps + collect (format nil "lxc.idmap = u ~D ~D ~D" + inside outside count))) + (gid-maps (loop for (inside outside count) in gid-maps + collect (format nil "lxc.idmap = g ~D ~D ~D" + inside outside count))) + (rootfs + (strcat + "dir:" + (unix-namestring + (merge-pathnames + "rootfs" + (merge-pathnames directory (get-connattr :remote-home))))))) + (file:has-content (merge-pathnames "config" directory) + (append prelude-lines uid-maps gid-maps + (list (strcat "lxc.rootfs.path = " rootfs) + (strcat "lxc.start.auto = " (if autostart "1" "0")) + (strcat "lxc.uts.name = " hostname)) + additional-lines) + :mode #o640)))) + +(defpropspec user-container-for :lisp + (options user host &optional additional-properties + &aux (host* (preprocess-host + (make-child-host + :hostattrs (hostattrs host) + :propspec (host-propspec + (union-propspec-into-host + host additional-properties)))))) + "Build an unprivileged, non-system-wide LXC container for HOST. +Must be applied using a connection chain which grants root access, primarily +for the sake of bootstrapping the container's root filesystem. Once built, +however, the container will be launched by USER, which should be non-root. + +If the container has already been bootstrapped and is running at the time this +property is applied, enter the container and apply all its properties. + +OPTIONS is a plist of keyword parameters: + + - :AUTOSTART -- Lisp boolean corresponding to lxc.start.auto in the + container's config file, and also determines whether applying this + property attempts to start the container. Defaults to nil. See also + LXC:USER-CONTAINERS-AUTOSTART. + + - :PRELUDE-LINES -- additional lines to prepend to the container's + configuration file, before the lines generated by this property. See + lxc.container.conf(5). The default value is usually sufficient; if you + add lines, you will probably want to include the lines from the default + value too. + + - :ADDITIONAL-LINES -- additional lines to append to the container's + configuration file, after the lines generated by this property. See + lxc.container.conf(5). In most cases you will need to include, at a + minimum, lines setting up a network interface for the container. The + default value serves as an example of a standard way to do this; if you + use them unmodified, you will also need to apply LXC:USERNET-USABLE-BY for + USER before this property. + + - :UID-MAPS -- a list of the form (INSIDE OUTSIDE COUNT), or a list of such + lists, specifying the subordinate UIDs for the container's user namespace. + OUTSIDE is the beginning of a UID range, as seen from outside the + container, and INSIDE is the UID that OUTSIDE is mapped to, as seen from + inside the container. COUNT is the number of consecutive UIDs mapped. + This property will ensure that USER has permission to use that range of + UIDs by updating /etc/subuid if necessary. + + As a special case, if NIL, instead use the first range of UIDs assigned to + USER in /etc/subuid, with a value of zero for INSIDE, and do not modify + /etc/subuid. (If you want to use the first range of UIDs assigned to USER + in /etc/subuid and also other ranges, you must specify them all explicitly + and cannot rely on this special case.) + + It is usually sufficient not to specify this parameter, as distribution + scripts automatically add an entry to /etc/subuid for each regular user, + and most containers use a value of zero for INSIDE. + + - :GID-MAPS -- as :UID-MAPS, but for GIDs and /etc/subgid. + + - :CHROOT-OPTIONS -- passed on to CHROOT:OS-BOOTSTRAPPED-FOR, which see. + +A limitation of the current implementation is the the root filesystem of the +container is always created under ~/.local/share/lxc/HOSTNAME where HOSTNAME +is the hostname of HOST, ignoring any configured XDG_DATA_HOME for USER. + +Internally we use setns(2) to enter the container. See \"Connections which +use setns(2) to enter containers\" in the Consfigurator manual for security +implications." + (:desc #?"LXC container for ${(get-hostname host*)} configured") + ;; Same hostname probably means that the container HOST inherited the + ;; container host's hostname as one was not explicitly set; probably a + ;; mistake. + (when (string= (get-hostname host*) (get-hostname)) + (aborted-change "LXC container has same hostname as container host.")) + (destructuring-bind + (&key chroot-options autostart uid-maps gid-maps + (prelude-lines '("lxc.include = /usr/share/lxc/config/common.conf" + "lxc.include = /usr/share/lxc/config/userns.conf")) + (additional-lines '("lxc.net.0.type = veth" + "lxc.net.0.flags = up" + "lxc.net.0.link = lxcbr0")) + &aux + (directory + (ensure-directory-pathname + (merge-pathnames (get-hostname host*) ".local/share/lxc/"))) + (rootfs (merge-pathnames "rootfs/" directory)) + (uid-maps (if (listp (car uid-maps)) uid-maps (list uid-maps))) + (gid-maps (if (listp (car gid-maps)) gid-maps (list gid-maps)))) + options + `(eseqprops + (installed) + (user:has-account ,user) + (systemd:lingering-enabled ,user) ; required for lxc-ls(1) to work at all + ,@(aand (loop for (inside outside count) in uid-maps + collect (format nil "~A:~D:~D" user outside count)) + `((desc ,#?"/etc/subuid has mappings for ${(get-hostname host*)}" + (file:contains-lines "/etc/subuid" ,@it)))) + ,@(aand (loop for (inside outside count) in gid-maps + collect (format nil "~A:~D:~D" user outside count)) + `((desc ,#?"/etc/subgid has mappings for ${(get-hostname host*)}" + (file:contains-lines "/etc/subgid" ,@it)))) + ,(propapp (desc "Base directory for container exists" + (as user (file:directory-exists directory)))) + (with-homedir (:user ,user) + (with-flagfile ,(merge-pathnames "rootfs.bootstrapped" directory) + ;; It would be nice to branch here such that if we are about to + ;; start up the container and enter it, just bootstrap a minimal + ;; root filesystem, and only otherwise get all the other properties + ;; applied before the ID shifting. I.e. + ;; + ;; (chroot:os-bootstrapped-for + ;; ,chroot-options ,rootfs + ;; ,@(if autostart + ;; `(,(make-host :hostattrs + ;; (list :os (get-hostattrs :os host*)))) + ;; `(,host ,additional-properties))) + ;; + ;; However, it might be that we need to apply the other properties + ;; in order that the container is startable; for example, getting + ;; systemd installed. + (chroot:os-bootstrapped-for + ,chroot-options ,rootfs ,host ,additional-properties) + (%ids-shifted-for ,user ,directory ,uid-maps ,gid-maps))) + ,(propapp + (desc "Container configuration file populated" + (as user + (%container-config-populated + prelude-lines user uid-maps gid-maps directory autostart + (car (split-string (get-hostname host*) :separator ".")) + additional-lines)))) + ,@(and autostart `((user-container-started ,host ,user))) + (when-user-container-running (,host :owner ,user) + (deploys ((:lxc :owner ,user :name ,(get-hostname host*))) + ,host ,additional-properties))))) + +(defproplist user-container :lisp (options user properties) + "Like LXC:USER-CONTAINER-FOR but define a new host using PROPERTIES." + (:desc "LXC container defined") + (user-container-for options user (make-host :propspec properties))) + + +;;;; Utility functions + +(defun lxc-cmd (&optional owner &rest cmd-and-args) + (let* ((runuser + (and owner (not (string= owner (get-connattr :remote-user))))) + (uid (if runuser + (user:passwd-entry 2 owner) + (get-connattr :remote-uid)))) + (apply #'run :env `(:DBUS_SESSION_BUS_ADDRESS nil + :XDG_RUNTIME_DIR ,(format nil "/run/user/~D" uid)) + (and runuser (list "runuser" "-u" owner "--")) cmd-and-args))) + +(defun lxc-ls (&optional owner &rest args) + "Return the lines of output from lxc-ls(1) called with ARGS and for OWNER." + (lines (apply #'lxc-cmd owner "lxc-ls" args))) + +(defun user-container-active-p (host &optional owner) + (and (not (service:no-services-p)) + (memstring= (get-hostname host) (lxc-ls owner "--active")))) + +(defun user-container-running-p (host &optional owner) + (and (not (service:no-services-p)) + (memstring= (get-hostname host) (lxc-ls owner "--running")))) -- cgit v1.2.3