add LXC properties, :LXC{,-UNPRIV-ATTACH} connections, WITH-HOMEDIR

Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>

1 files changed, 329 insertions, 0 deletions

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 <spwhitton@spwhitton.name>
+
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(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"))))