diff options
| -rw-r--r-- | src/connection.lisp | 10 | ||||
| -rw-r--r-- | src/connection/chroot.lisp | 5 | ||||
| -rw-r--r-- | src/package.lisp | 8 | ||||
| -rw-r--r-- | src/property/chroot.lisp | 4 | ||||
| -rw-r--r-- | src/property/disk.lisp | 2 | ||||
| -rw-r--r-- | src/property/file.lisp | 30 | ||||
| -rw-r--r-- | src/property/installer.lisp | 8 | ||||
| -rw-r--r-- | src/property/locale.lisp | 2 | ||||
| -rw-r--r-- | src/property/lxc.lisp | 2 | ||||
| -rw-r--r-- | src/property/mount.lisp | 6 | ||||
| -rw-r--r-- | src/property/ssh.lisp | 2 | ||||
| -rw-r--r-- | src/util.lisp | 2 | ||||
| -rw-r--r-- | src/util/linux-namespace.lisp | 2 |
13 files changed, 42 insertions, 41 deletions
diff --git a/src/connection.lisp b/src/connection.lisp index 9a7584f..d5d1618 100644 --- a/src/connection.lisp +++ b/src/connection.lisp @@ -521,10 +521,10 @@ expected." (defun runlines (&rest args) (lines (apply #'run args))) -(defun test (&rest args) +(defun remote-test (&rest args) (zerop (apply #'mrun :for-exit "test" args))) -(defun mountpointp (path) +(defun remote-mount-point-p (path) "Is PATH a mount point? Uses mountpoint(1) from util-linux, so add a property requiring OS:LINUX or a @@ -543,9 +543,9 @@ subclass to the :HOSTATTRS subroutine of properties calling this." (defun remote-exists-p (&rest paths) "Does each of PATHS exists? PATH may be any kind of file, including directories." - (apply #'test (loop for path on paths - nconc (list "-e" (car path)) - when (cdr path) collect "-a"))) + (apply #'remote-test (loop for path on paths + nconc (list "-e" (car path)) + when (cdr path) collect "-a"))) (defun remote-file-stats (path) "Get the numeric mode, size in bytes and mtime of PATH, or NIL if it does not diff --git a/src/connection/chroot.lisp b/src/connection/chroot.lisp index 4c1db70..aeae134 100644 --- a/src/connection/chroot.lisp +++ b/src/connection/chroot.lisp @@ -46,7 +46,7 @@ should be the mount point, without the chroot's root prefixed.") (slot-value connection 'into)))) ;; We only mount when the target is not already a mount point, so we ;; don't shadow anything that the user has already set up. - (unless (mountpointp dest) + (unless (remote-mount-point-p dest) (setq mount-args (copy-list mount-args)) (setf (lastcar mount-args) dest) (apply #'mrun "mount" mount-args) @@ -57,7 +57,8 @@ should be the mount point, without the chroot's root prefixed.") (with-slots (into) connection ;; Ensure the chroot itself is a mountpoint so that findmnt(8) works ;; correctly within the chroot. - (unless (mountpointp into) (chroot-mount connection "--bind" into "/")) + (unless (remote-mount-point-p into) + (chroot-mount connection "--bind" into "/")) ;; Now set up the usual bind mounts. Help here from arch-chroot(8). (mount:assert-devtmpfs-udev-/dev) (dolist (mount mount:*standard-linux-vfs*) diff --git a/src/package.lisp b/src/package.lisp index ae39cd2..c5a4b9a 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -111,7 +111,7 @@ #:systemd--user #:with-local-temporary-directory #:pathname-file - #:directory-contents + #:local-directory-contents #:ensure-trailing-slash #:drop-trailing-slash #:define-print-object-for-structlike @@ -178,12 +178,12 @@ #:failed-stderr #:failed-exit-code #:runlines - #:test + #:remote-test #:remote-exists-p #:remote-file-stats #:remote-last-reboot #:remote-executable-find - #:mountpointp + #:remote-mount-point-p #:delete-remote-trees #:empty-remote-directory #:readfile @@ -426,7 +426,7 @@ (package :consfigurator.property.file (:local-nicknames (#:re #:cl-ppcre)) - (:export #:map-file-lines + (:export #:map-remote-file-lines #:has-content #:exists-with-content #:contains-lines diff --git a/src/property/chroot.lisp b/src/property/chroot.lisp index bf4b942..5b1c9b1 100644 --- a/src/property/chroot.lisp +++ b/src/property/chroot.lisp @@ -23,8 +23,8 @@ (:check (declare (ignore options host)) ;; check whether a previous debootstrap failed partway through - (if (test "-d" (merge-pathnames "debootstrap/" - (ensure-directory-pathname root))) + (if (remote-test "-d" (merge-pathnames "debootstrap/" + (ensure-directory-pathname root))) (progn (delete-remote-trees root) nil) (remote-exists-p (chroot-pathname "/usr/lib/os-release" root)))) (:apply diff --git a/src/property/disk.lisp b/src/property/disk.lisp index 9466b5d..3054441 100644 --- a/src/property/disk.lisp +++ b/src/property/disk.lisp @@ -283,7 +283,7 @@ directly writing out with dd(1).")) (defmethod create-volume ((volume raw-disk-image) (file null)) "Ensure that a raw disk image exists. Will overwrite only regular files." (let ((file (image-file volume))) - (when (test "-L" file "-o" "-e" file "-a" "!" "-f" file) + (when (remote-test "-L" file "-o" "-e" file "-a" "!" "-f" file) (failed-change "~A already exists and is not a regular file." file)) ;; Here, following Propellor, we want to ensure that the disk image size ;; is a multiple of 4096 bytes, so that the size is aligned to the common diff --git a/src/property/file.lisp b/src/property/file.lisp index bd940f3..26ce4a1 100644 --- a/src/property/file.lisp +++ b/src/property/file.lisp @@ -18,7 +18,7 @@ (in-package :consfigurator.property.file) (named-readtables:in-readtable :consfigurator) -(defun map-file-lines (file function) +(defun map-remote-file-lines (file function) "Apply FUNCTION to the lines of FILE. Safe to use in a :POSIX property. For efficiency, a :LISP property might want to use streams, but there's no @@ -76,7 +76,7 @@ replacing the contents of existing files, prefer FILE:HAS-CONTENT." (defprop lacks-lines :posix (path &rest lines) "If there is a file at PATH, ensure it does not contain any of LINES." (:apply - (map-file-lines + (map-remote-file-lines path (curry #'remove-if (lambda (l) (member l lines :test #'string=)))))) @@ -85,7 +85,7 @@ replacing the contents of existing files, prefer FILE:HAS-CONTENT." any of the regular expressions PATTERNS." (:apply (let ((scanners (mapcar #'re:create-scanner patterns))) - (map-file-lines + (map-remote-file-lines path (lambda (lines) (loop for line in lines unless (loop for s in scanners thereis (re:scan s line)) @@ -176,7 +176,7 @@ any of the regular expressions PATTERNS." "Like s/REGEX/REPLACE/ on the lines of FILE. Uses CL-PPCRE:REGEX-REPLACE, which see for the syntax of REPLACE." (:apply - (map-file-lines + (map-remote-file-lines file (lambda (lines) (mapcar (lambda (line) (re:regex-replace regex line replace)) lines))))) @@ -226,7 +226,7 @@ error if FROM is another kind of file, except when unapplying." "FILE:SYMLINKED: need both :FROM and :TO arguments.")) (when (pathnamep to) (setq to (unix-namestring to))) - (let* ((link (test "-L" from)) + (let* ((link (remote-test "-L" from)) (exists (remote-exists-p from))) (when (and exists (not link)) (failed-change "~A exists but is not a symbolic link." from)) @@ -236,7 +236,7 @@ error if FROM is another kind of file, except when unapplying." (containing-directory-exists from) (mrun "ln" "-sf" to from))))) (:unapply (declare (ignore to)) - (if (test "-L" from) + (if (remote-test "-L" from) (mrun "rm" from) :no-change))) @@ -245,7 +245,7 @@ error if FROM is another kind of file, except when unapplying." symbolic link, in which case the target of the link will be copied." (:desc #?"${dest} is copy of ${source}") (:check - (and (test "-f" dest) + (and (remote-test "-f" dest) (zerop (mrun :for-exit "cmp" "-s" dest source)))) (:apply (with-remote-temporary-file @@ -264,11 +264,11 @@ symbolic link, in which case the target of the link will be copied." (&key (parse-comment "#") (new-comment "# ") (parse-section (constantly nil)) (new-section #'identity) parse-kv new-kv map) - "Return a function suitable for passing to FILE:MAP-FILE-LINES, to modify -the lines of a config file using MAP. MAP is a function from a list of config -file lines to a list of config file lines, except that lines which set values -in the original file will be replaced by lists of the form (COMMENTED SECTION -KEY VALUE), where + "Return a function suitable for passing to FILE:MAP-REMOTE-FILE-LINES, to +modify the lines of a config file using MAP. MAP is a function from a list of +config file lines to a list of config file lines, except that lines which set +values in the original file will be replaced by lists of the form (COMMENTED +SECTION KEY VALUE), where - COMMENTED is a boolean indicating whether the line was commented - SECTION is the section of the config file in which the line appears @@ -365,7 +365,7 @@ Other arguments: "Values passed are not all strings, or list is not even") do (setf (gethash k keys) v)) (containing-directory-exists file) - (map-file-lines + (map-remote-file-lines file (apply #'config-file-map :map @@ -456,7 +456,7 @@ removed, and semicolon comment chars will be replaced with '#'." (keys (make-hash-table :test #'equal))) (loop for (s k v) in triples do (setf (gethash (cons s k) keys) v)) - (map-file-lines + (map-remote-file-lines file (config-file-map :parse-comment "[#;]" @@ -525,7 +525,7 @@ an attempt is made to activate the swap, set up the bind mount, etc." (dolist (entry entries) (setf (gethash (nth target (words entry)) pending) entry)) (containing-directory-exists file) - (map-file-lines + (map-remote-file-lines file (lambda (lines) (stable-sort diff --git a/src/property/installer.lisp b/src/property/installer.lisp index 43c6c9d..63d8c63 100644 --- a/src/property/installer.lisp +++ b/src/property/installer.lisp @@ -189,7 +189,7 @@ using a combinator like ON-CHANGE, or applied manually with DEPLOY-THESE." (flet ((preservedp (pathname) (member pathname preserved-directories :test #'pathname-equal))) (mount:assert-devtmpfs-udev-/dev) - (unless (mountpointp "/run") + (unless (remote-mount-point-p "/run") (failed-change "/run is not a mount point; don't know what to do.")) ;; If there's an EFI system partition, we need to store knowledge of @@ -198,7 +198,7 @@ using a combinator like ON-CHANGE, or applied manually with DEPLOY-THESE." ;; is responsible for adding an entry for the EFI system partition to ;; the new system's fstab, but we are responsible for restoring ;; knowledge of the partition to the kernel's mount table. - (when (mountpointp "/boot/efi") + (when (remote-mount-point-p "/boot/efi") (destructuring-bind (type source options) (words (stripln (run "findmnt" "-nro" "FSTYPE,SOURCE,OPTIONS" "/boot/efi"))) @@ -237,12 +237,12 @@ using a combinator like ON-CHANGE, or applied manually with DEPLOY-THESE." (let (done) (handler-case (flet ((rename (s d) (rename-file s d) (push (cons s d) done))) - (dolist (file (directory-contents #P"/")) + (dolist (file (local-directory-contents #P"/")) (unless (or (preservedp file) (pathname-equal file new-os) (pathname-equal file old-os)) (rename file (chroot-pathname file old-os)))) - (dolist (file (directory-contents new-os)) + (dolist (file (local-directory-contents new-os)) (let ((dest (in-chroot-pathname file new-os))) (unless (preservedp dest) (when (or (file-exists-p dest) (directory-exists-p dest)) diff --git a/src/property/locale.lisp b/src/property/locale.lisp index 524a0dc..eafde35 100644 --- a/src/property/locale.lisp +++ b/src/property/locale.lisp @@ -22,7 +22,7 @@ (:desc (declare (ignore locale)) "/etc/locale.gen updated") (:apply (assert-euid-root) - (file:map-file-lines + (file:map-remote-file-lines "/etc/locale.gen" (lambda (lines) (loop with found diff --git a/src/property/lxc.lisp b/src/property/lxc.lisp index b32f091..05aafc8 100644 --- a/src/property/lxc.lisp +++ b/src/property/lxc.lisp @@ -100,7 +100,7 @@ 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 + (:apply (file:map-remote-file-lines "/etc/lxc/lxc-usernet" (lambda (lines) (loop with done diff --git a/src/property/mount.lisp b/src/property/mount.lisp index f4a06ed..dc6a559 100644 --- a/src/property/mount.lisp +++ b/src/property/mount.lisp @@ -82,10 +82,10 @@ and unless DIR is itself a mount point, also remove DIR." (:desc #?"${dir} unmounted below and emptied/removed") (:hostattrs (os:required 'os:linux)) (:check (or (not (remote-exists-p dir)) - (and (mountpointp dir) + (and (remote-mount-point-p dir) (null (runlines "find" dir "-not" "-path" dir))))) (:apply (ignoring-hostattrs (unmounted-below dir :and-at nil)) - (if (mountpointp dir) + (if (remote-mount-point-p dir) (empty-remote-directory dir) (delete-remote-trees dir)))) @@ -119,7 +119,7 @@ After mounting /sys, mount this when /sys/firmware/efi/efivars exists.") (defun assert-devtmpfs-udev-/dev () "On a system with the Linux kernel, assert that /dev has fstype devtmpfs." - (unless (and (mountpointp "/dev") + (unless (and (remote-mount-point-p "/dev") (string= "devtmpfs udev" (stripln (run "findmnt" "-nro" "fstype,source" "/dev")))) (failed-change diff --git a/src/property/ssh.lisp b/src/property/ssh.lisp index de1f153..3f98d2a 100644 --- a/src/property/ssh.lisp +++ b/src/property/ssh.lisp @@ -45,7 +45,7 @@ (defprop %update-known-hosts :posix (file host &key short-hostname (aliases t) (ips t) additional-names) (:apply - (file:map-file-lines + (file:map-remote-file-lines file (lambda (lines) (loop with host = (preprocess-host host) diff --git a/src/util.lisp b/src/util.lisp index 1c65449..a0110ef 100644 --- a/src/util.lisp +++ b/src/util.lisp @@ -209,7 +209,7 @@ directory, one solution is to convert your property to a :LISP property." (enough-pathname pathname (pathname-directory-pathname pathname)) pathname)))) -(defun directory-contents (pathname) +(defun local-directory-contents (pathname) "Return the immediate contents of PATHNAME, a directory, without resolving symlinks. Not suitable for use by :POSIX properties." ;; On SBCL on Debian UIOP:*WILD-FILE-FOR-DIRECTORY* is #P"*.*". diff --git a/src/util/linux-namespace.lisp b/src/util/linux-namespace.lisp index 98b36d6..3844de2 100644 --- a/src/util/linux-namespace.lisp +++ b/src/util/linux-namespace.lisp @@ -117,7 +117,7 @@ CONSFIGURATOR.UTIL.LINUX-NAMESPACE:REDUCE-ID-MAPS and user_namespaces(7)." (shift-acl file +ACL-TYPE-ACCESS+) (when dirp (shift-acl file +ACL-TYPE-DEFAULT+))) (when (and dirp (not linkp)) - (mapc #'shift (directory-contents file)))))) + (mapc #'shift (local-directory-contents file)))))) (shift-acl (file type) (with-acl-free (acl (acl-get-file file type)) (with-foreign-objects |