aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSean Whitton <spwhitton@spwhitton.name>2021-03-22 09:38:57 -0700
committerSean Whitton <spwhitton@spwhitton.name>2021-03-22 09:38:57 -0700
commitf393eeebe8cf6a31ecc2160658bee3d2c895a98b (patch)
treeb6c85fc026ffafc58f3c1479efadebb8ba699934
parent2063385338300dfb11cd1a681ba0ca9e7b1aaf37 (diff)
downloadconsfigurator-f393eeebe8cf6a31ecc2160658bee3d2c895a98b.tar.gz
untabify
Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>
-rw-r--r--.dir-locals.el7
-rw-r--r--consfigurator.asd68
-rw-r--r--src/combinator.lisp130
-rw-r--r--src/connection.lisp194
-rw-r--r--src/connection/chroot.lisp12
-rw-r--r--src/connection/chroot/fork.lisp62
-rw-r--r--src/connection/chroot/shell.lisp6
-rw-r--r--src/connection/local.lisp22
-rw-r--r--src/connection/sbcl.lisp14
-rw-r--r--src/connection/shell-wrap.lisp26
-rw-r--r--src/connection/ssh.lisp10
-rw-r--r--src/connection/sudo.lisp64
-rw-r--r--src/data.lisp318
-rw-r--r--src/data/asdf.lisp26
-rw-r--r--src/data/pgp.lisp54
-rw-r--r--src/deployment.lisp98
-rw-r--r--src/host.lisp38
-rw-r--r--src/package.lisp420
-rw-r--r--src/property.lisp274
-rw-r--r--src/property/apt.lisp38
-rw-r--r--src/property/chroot.lisp36
-rw-r--r--src/property/file.lisp16
-rw-r--r--src/property/os.lisp74
-rw-r--r--src/property/service.lisp52
-rw-r--r--src/propspec.lisp132
-rw-r--r--src/util.lisp178
26 files changed, 1188 insertions, 1181 deletions
diff --git a/.dir-locals.el b/.dir-locals.el
new file mode 100644
index 0000000..30ed8a4
--- /dev/null
+++ b/.dir-locals.el
@@ -0,0 +1,7 @@
+;;; Directory Local Variables
+;;; For more information see (info "(emacs) Directory Variables")
+
+((nil . ((tab-width . 8)
+ (fill-column . 78)
+ (sentence-end-double-space . t)))
+ (lisp-mode . ((indent-tabs-mode . nil))))
diff --git a/consfigurator.asd b/consfigurator.asd
index 9a36fa6..bf5c9b7 100644
--- a/consfigurator.asd
+++ b/consfigurator.asd
@@ -5,38 +5,38 @@
:licence "GPL-3+"
:serial t
:depends-on (#:alexandria
- #:babel
- #:babel-streams
- #:cl-ppcre
- #:cl-heredoc
- #:cl-interpol
- #:named-readtables
- #:cffi
- #:trivial-macroexpand-all)
+ #:babel
+ #:babel-streams
+ #:cl-ppcre
+ #:cl-heredoc
+ #:cl-interpol
+ #:named-readtables
+ #:cffi
+ #:trivial-macroexpand-all)
:components ((:file "src/package")
- (:file "src/reader")
- (:file "src/util")
- (:file "src/connection")
- (:file "src/property")
- (:file "src/propspec")
- (:file "src/host")
- (:file "src/combinator")
- (:file "src/deployment")
- (:file "src/connection/local")
- (:file "src/data")
- (:file "src/property/cmd")
- (:file "src/property/file")
- (:file "src/property/os")
- (:file "src/property/service")
- (:file "src/property/apt")
- (:file "src/property/chroot")
- (:file "src/property/user")
- (:file "src/connection/shell-wrap")
- (:file "src/connection/ssh")
- (:file "src/connection/sudo")
- (:file "src/connection/sbcl")
- (:file "src/connection/chroot")
- (:file "src/connection/chroot/fork")
- (:file "src/connection/chroot/shell")
- (:file "src/data/asdf")
- (:file "src/data/pgp")))
+ (:file "src/reader")
+ (:file "src/util")
+ (:file "src/connection")
+ (:file "src/property")
+ (:file "src/propspec")
+ (:file "src/host")
+ (:file "src/combinator")
+ (:file "src/deployment")
+ (:file "src/connection/local")
+ (:file "src/data")
+ (:file "src/property/cmd")
+ (:file "src/property/file")
+ (:file "src/property/os")
+ (:file "src/property/service")
+ (:file "src/property/apt")
+ (:file "src/property/chroot")
+ (:file "src/property/user")
+ (:file "src/connection/shell-wrap")
+ (:file "src/connection/ssh")
+ (:file "src/connection/sudo")
+ (:file "src/connection/sbcl")
+ (:file "src/connection/chroot")
+ (:file "src/connection/chroot/fork")
+ (:file "src/connection/chroot/shell")
+ (:file "src/data/asdf")
+ (:file "src/data/pgp")))
diff --git a/src/combinator.lisp b/src/combinator.lisp
index 41c43db..c6e89e7 100644
--- a/src/combinator.lisp
+++ b/src/combinator.lisp
@@ -27,37 +27,37 @@
,@(and docstring `(,docstring))
,@declarations
(flet ((:retprop (&rest all &key args &allow-other-keys)
- (let ((psym (gensym ,(symbol-name name)))
- (setprop-args (remove-from-plist all :args)))
- (apply #'setprop psym setprop-args)
- (return-from ,name (list* psym args)))))
- ,@forms))))
+ (let ((psym (gensym ,(symbol-name name)))
+ (setprop-args (remove-from-plist all :args)))
+ (apply #'setprop psym setprop-args)
+ (return-from ,name (list* psym args)))))
+ ,@forms))))
(defmacro with-skip-failed-changes (&body forms)
`(handler-bind ((failed-change
- (lambda (c)
- (with-indented-inform
- (informat t
- (simple-condition-format-control c)
- (simple-condition-format-arguments c)))
- (invoke-restart 'skip-property))))
+ (lambda (c)
+ (with-indented-inform
+ (informat t
+ (simple-condition-format-control c)
+ (simple-condition-format-arguments c)))
+ (invoke-restart 'skip-property))))
,@forms))
(define-function-property-combinator eseqprops (&rest propapps)
(:retprop :type (collapse-types (mapcar #'propapptype propapps))
- :hostattrs (lambda () (mapc #'propappattrs propapps))
- :apply (lambda () (apply-and-print propapps))
- :unapply (lambda () (apply-and-print propapps t))))
+ :hostattrs (lambda () (mapc #'propappattrs propapps))
+ :apply (lambda () (apply-and-print propapps))
+ :unapply (lambda () (apply-and-print propapps t))))
(define-function-property-combinator seqprops (&rest propapps)
(:retprop :type (collapse-types (mapcar #'propapptype propapps))
- :hostattrs (lambda () (mapc #'propappattrs propapps))
- :apply (lambda ()
- (with-skip-failed-changes
- (apply-and-print propapps)))
- :unapply (lambda ()
- (with-skip-failed-changes
- (apply-and-print propapps t)))))
+ :hostattrs (lambda () (mapc #'propappattrs propapps))
+ :apply (lambda ()
+ (with-skip-failed-changes
+ (apply-and-print propapps)))
+ :unapply (lambda ()
+ (with-skip-failed-changes
+ (apply-and-print propapps t)))))
(defmacro with-requirements (propapp &body requirements)
"Apply PROPAPP only after applying each dependency in REQUIREMENTS.
@@ -67,46 +67,46 @@ apply the elements of REQUIREMENTS in reverse order."
(define-function-property-combinator silent-seqprops (&rest propapps)
(:retprop :type (collapse-types (mapcar #'propapptype propapps))
- :hostattrs (lambda () (mapc #'propappattrs propapps))
- :apply (lambda ()
- (with-skip-failed-changes
- (mapc #'propappapply propapps)))
- :unapply (lambda ()
- (with-skip-failed-changes
- (mapc #'propappunapply (reverse propapps))))))
+ :hostattrs (lambda () (mapc #'propappattrs propapps))
+ :apply (lambda ()
+ (with-skip-failed-changes
+ (mapc #'propappapply propapps)))
+ :unapply (lambda ()
+ (with-skip-failed-changes
+ (mapc #'propappunapply (reverse propapps))))))
;; note that the :FAILED-CHANGE value is only used within this function and
;; should not be returned by property subroutines, per the spec
(defun apply-and-print (propapps &optional unapply)
(dolist (pa (if unapply (reverse propapps) propapps))
(let* ((result (restart-case
- (with-indented-inform
- (if unapply (propappunapply pa) (propappapply pa)))
- (skip-property () :failed-change)))
- (status (case result
- (:no-change "ok")
- (:failed-change "failed")
- (t "done"))))
+ (with-indented-inform
+ (if unapply (propappunapply pa) (propappapply pa)))
+ (skip-property () :failed-change)))
+ (status (case result
+ (:no-change "ok")
+ (:failed-change "failed")
+ (t "done"))))
(informat t "~&~@[~A :: ~]~@[~A ... ~]~A~%"
- (get-hostname) (propappdesc pa) status))))
+ (get-hostname) (propappdesc pa) status))))
(define-function-property-combinator unapply (propapp)
(destructuring-bind (psym . args) propapp
(:retprop :type (proptype psym)
- :lambda (proplambda psym)
- :desc (lambda (&rest args)
- (strcat "Unapply: " (apply #'propdesc psym args)))
- :check (when-let ((check (get psym 'check)))
- (complement check))
- :hostattrs (lambda (&rest args)
- ;; run the :HOSTATTRS subroutine but throw away any
- ;; new hostattrs; when unapplying, the :HOSTATTRS
- ;; subroutine is only to check compatibility
- (with-preserve-hostattrs
- (apply #'propattrs psym args)))
- :apply (get psym 'unapply)
- :unapply (get psym 'papply)
- :args args)))
+ :lambda (proplambda psym)
+ :desc (lambda (&rest args)
+ (strcat "Unapply: " (apply #'propdesc psym args)))
+ :check (when-let ((check (get psym 'check)))
+ (complement check))
+ :hostattrs (lambda (&rest args)
+ ;; run the :HOSTATTRS subroutine but throw away any
+ ;; new hostattrs; when unapplying, the :HOSTATTRS
+ ;; subroutine is only to check compatibility
+ (with-preserve-hostattrs
+ (apply #'propattrs psym args)))
+ :apply (get psym 'unapply)
+ :unapply (get psym 'papply)
+ :args args)))
(defmacro on-change (propapp &body on-change)
"If applying PROPAPP makes a change, also apply each of of the propapps
@@ -115,18 +115,18 @@ ON-CHANGE in order."
(define-function-property-combinator on-change* (propapp &rest propapps)
(:retprop :type (collapse-types (propapptype propapp)
- (mapcar #'propapptype propapps))
- :desc (get (car propapp) 'desc)
- :hostattrs (lambda (&rest args)
- (apply #'propattrs (car propapp) args))
- :apply (lambda (&rest args)
- (unless (eq (propappapply (cons (car propapp) args))
- :no-change)
- (dolist (propapp propapps)
- (propappapply propapp))))
- :unapply (lambda (&rest args)
- (unless (eq (propappunapply (cons (car propapp) args))
- :no-change)
- (dolist (propapp (reverse propapps))
- (propappunapply propapp))))
- :args (cdr propapp)))
+ (mapcar #'propapptype propapps))
+ :desc (get (car propapp) 'desc)
+ :hostattrs (lambda (&rest args)
+ (apply #'propattrs (car propapp) args))
+ :apply (lambda (&rest args)
+ (unless (eq (propappapply (cons (car propapp) args))
+ :no-change)
+ (dolist (propapp propapps)
+ (propappapply propapp))))
+ :unapply (lambda (&rest args)
+ (unless (eq (propappunapply (cons (car propapp) args))
+ :no-change)
+ (dolist (propapp (reverse propapps))
+ (propappunapply propapp))))
+ :args (cdr propapp)))
diff --git a/src/connection.lisp b/src/connection.lisp
index 3ef8d5b..b993761 100644
--- a/src/connection.lisp
+++ b/src/connection.lisp
@@ -125,9 +125,9 @@ Implementations can specialise on both the CONNECTION and CONTENT arguments,
if they need to handle streams and strings differently."))
(defmethod connection-writefile :around ((connection connection)
- path
- content
- mode)
+ path
+ content
+ mode)
(declare (ignore path content mode))
(let ((*connection* (slot-value connection 'parent)))
(call-next-method)))
@@ -167,19 +167,19 @@ the root Lisp's machine. For example, using rsync(1) over SSH."))
(stderr :initarg :stderr :reader failed-stderr)
(exit-code :initarg :exit-code :reader failed-exit-code))
(:report (lambda (condition stream)
- (format
- stream
- "~&'~A' failed, exit code ~A~%~%stdout was:~%~A~&~%stderr:~%~A"
- (failed-cmd condition)
- (failed-exit-code condition)
- (failed-stdout condition)
- (failed-stderr condition)))))
+ (format
+ stream
+ "~&'~A' failed, exit code ~A~%~%stdout was:~%~A~&~%stderr:~%~A"
+ (failed-cmd condition)
+ (failed-exit-code condition)
+ (failed-stdout condition)
+ (failed-stderr condition)))))
(defmacro with-remote-temporary-file ((file
- &key
- (connection '*connection*)
- (directory nil directory-supplied-p))
- &body body)
+ &key
+ (connection '*connection*)
+ (directory nil directory-supplied-p))
+ &body body)
"Execute BODY with FILE containing the path to a freshly created remote file,
which will be cleaned up when BODY is finished."
;; it would be nicer if we could just use (file &rest args) but we need to
@@ -187,71 +187,71 @@ which will be cleaned up when BODY is finished."
;; evaluated more than once
(once-only (connection)
`(let ((,file (mktemp ,@(and directory-supplied-p
- `(:directory ,directory))
- :connection ,connection)))
+ `(:directory ,directory))
+ :connection ,connection)))
(unwind-protect
- (progn ,@body)
- (connection-run ,connection
- (format nil "rm -f ~A" (escape-sh-token ,file))
- nil)))))
+ (progn ,@body)
+ (connection-run ,connection
+ (format nil "rm -f ~A" (escape-sh-token ,file))
+ nil)))))
(defun mktemp (&key (connection *connection*) directory)
"Make a temporary file on the remote side, in DIRECTORY, defaulting to /tmp."
(let ((template (if directory
- (unix-namestring
- (merge-pathnames
- "tmp.XXXXXX" (ensure-directory-pathname directory)))
- "'${TMPDIR:-/tmp}'/tmp.XXXXXX")))
+ (unix-namestring
+ (merge-pathnames
+ "tmp.XXXXXX" (ensure-directory-pathname directory)))
+ "'${TMPDIR:-/tmp}'/tmp.XXXXXX")))
(multiple-value-bind (out exit)
- ;; mktemp(1) is not POSIX; the only POSIX way is this M4 way,
- ;; apparently, but even though m4(1) is POSIX it seems like it could
- ;; often be absent, so have a fallback. It would be better to avoid
- ;; passing any arguments to mktemp(1) as these may differ on different
- ;; platforms, but hopefully just a template is okay.
- ;;
- ;; While GNU M4 mkstemp makes the temporary file at most readable and
- ;; writeable by its owner, POSIX doesn't require this, so set a umask.
- (connection-run
- connection
- #?"umask 077; echo 'mkstemp(${template})' | m4 2>/dev/null || mktemp '${template}'"
- nil)
+ ;; mktemp(1) is not POSIX; the only POSIX way is this M4 way,
+ ;; apparently, but even though m4(1) is POSIX it seems like it could
+ ;; often be absent, so have a fallback. It would be better to avoid
+ ;; passing any arguments to mktemp(1) as these may differ on different
+ ;; platforms, but hopefully just a template is okay.
+ ;;
+ ;; While GNU M4 mkstemp makes the temporary file at most readable and
+ ;; writeable by its owner, POSIX doesn't require this, so set a umask.
+ (connection-run
+ connection
+ #?"umask 077; echo 'mkstemp(${template})' | m4 2>/dev/null || mktemp '${template}'"
+ nil)
(let ((lines (lines out)))
- (if (and (zerop exit) lines)
- (car lines)
- (error 'run-failed
- :cmd "(attempt to make a temporary file on remote)"
- :stdout out
- :stderr "(merged with stdout)"
- :exit-code exit))))))
+ (if (and (zerop exit) lines)
+ (car lines)
+ (error 'run-failed
+ :cmd "(attempt to make a temporary file on remote)"
+ :stdout out
+ :stderr "(merged with stdout)"
+ :exit-code exit))))))
(defmacro %process-run-args (&body forms)
`(let (cmd input may-fail for-exit env inform)
(loop for arg = (pop args)
- do (case arg
- (:for-exit (setq may-fail t for-exit t))
- (:may-fail (setq may-fail t))
- (:inform (setq inform t))
- (:input (setq input (pop args)))
- (:env (setq env (pop args)))
- (t (mapc (lambda (e)
- (push (typecase e
- (pathname
- (unix-namestring e))
- (t
- e))
- cmd))
- (ensure-list arg))))
- while args
- finally (nreversef cmd))
+ do (case arg
+ (:for-exit (setq may-fail t for-exit t))
+ (:may-fail (setq may-fail t))
+ (:inform (setq inform t))
+ (:input (setq input (pop args)))
+ (:env (setq env (pop args)))
+ (t (mapc (lambda (e)
+ (push (typecase e
+ (pathname
+ (unix-namestring e))
+ (t
+ e))
+ cmd))
+ (ensure-list arg))))
+ while args
+ finally (nreversef cmd))
(setq cmd (if (cdr cmd) (escape-sh-command cmd) (car cmd)))
(loop while env
- collect (format nil "~A=~A" (symbol-name (pop env)) (pop env))
- into accum
- finally
- (when accum
- (setq cmd (format nil "env ~{~A~^ ~} ~A"
- (mapcar #'escape-sh-token accum)
- cmd))))
+ collect (format nil "~A=~A" (symbol-name (pop env)) (pop env))
+ into accum
+ finally
+ (when accum
+ (setq cmd (format nil "env ~{~A~^ ~} ~A"
+ (mapcar #'escape-sh-token accum)
+ cmd))))
,@forms))
(defun run (&rest args)
@@ -288,13 +288,13 @@ case return only the exit code."
(setq cmd (format nil "( ~A ) >~A" cmd stdout))
(informat 3 "RUN ~A" cmd)
(multiple-value-bind (err exit)
- (connection-run *connection* cmd input)
- (let ((out (readfile stdout)))
- (when inform (informat 1 "~{ ~A~%~}" (lines out)))
- (if (or may-fail (= exit 0))
- (if for-exit exit (values out err exit))
- (error 'run-failed
- :cmd cmd :stdout out :stderr err :exit-code exit)))))))
+ (connection-run *connection* cmd input)
+ (let ((out (readfile stdout)))
+ (when inform (informat 1 "~{ ~A~%~}" (lines out)))
+ (if (or may-fail (= exit 0))
+ (if for-exit exit (values out err exit))
+ (error 'run-failed
+ :cmd cmd :stdout out :stderr err :exit-code exit)))))))
(defun mrun (&rest args)
"Like RUN but don't separate stdout and stderr (\"m\" for \"merged\"; note
@@ -311,15 +311,15 @@ start with RUN."
(%process-run-args
(informat 3 "MRUN ~A" cmd)
(multiple-value-bind (out exit)
- (connection-run *connection* cmd input)
+ (connection-run *connection* cmd input)
(when inform (informat 1 "~{ ~A~%~}" (lines out)))
(if (or may-fail (= exit 0))
- (if for-exit exit (values out exit))
- (error 'run-failed
- :cmd cmd
- :stdout out
- :stderr "(merged with stdout)"
- :exit-code exit)))))
+ (if for-exit exit (values out exit))
+ (error 'run-failed
+ :cmd cmd
+ :stdout out
+ :stderr "(merged with stdout)"
+ :exit-code exit)))))
(defun runlines (&rest args)
(lines (apply #'run args)))
@@ -331,10 +331,10 @@ start with RUN."
(apply #'connection-readfile *connection* args))
(defun writefile (path content
- &key (mode #o644 mode-supplied-p)
- &aux (namestring (etypecase path
- (pathname (unix-namestring path))
- (string path))))
+ &key (mode #o644 mode-supplied-p)
+ &aux (namestring (etypecase path
+ (pathname (unix-namestring path))
+ (string path))))
;; If (lisp-connection-p), the file already exists, and it's not owned by
;; us, we could (have a keyword argument to) bypass CONNECTION-WRITEFILE and
;; just WRITE-STRING to the file. That way we don't replace the file with
@@ -345,17 +345,17 @@ start with RUN."
;; seems there is nothing like stat(1) in POSIX, and note that
;; --reference for chmod(1) and chown(1) is not POSIX
(re:register-groups-bind
- (((lambda (s) (delete #\- s)) umode gmode omode) uid gid)
- (#?/^.(...)(...)(...).[0-9]+ ([0-9]+) ([0-9]+) /
- (mrun "ls" "-nd" path) :sharedp t)
- (connection-writefile *connection*
- namestring
- content
- mode)
- (let ((namestring (escape-sh-token namestring)))
- (unless mode-supplied-p
- ;; assume that if we can write it we can chmod it
- (mrun #?"chmod u=${umode},g=${gmode},o=${omode} ${namestring}"))
- ;; we may not be able to chown; that's okay
- (mrun :may-fail #?"chown ${uid}:${gid} ${path}")))
+ (((lambda (s) (delete #\- s)) umode gmode omode) uid gid)
+ (#?/^.(...)(...)(...).[0-9]+ ([0-9]+) ([0-9]+) /
+ (mrun "ls" "-nd" path) :sharedp t)
+ (connection-writefile *connection*
+ namestring
+ content
+ mode)
+ (let ((namestring (escape-sh-token namestring)))
+ (unless mode-supplied-p
+ ;; assume that if we can write it we can chmod it
+ (mrun #?"chmod u=${umode},g=${gmode},o=${omode} ${namestring}"))
+ ;; we may not be able to chown; that's okay
+ (mrun :may-fail #?"chown ${uid}:${gid} ${path}")))
(connection-writefile *connection* namestring content mode)))
diff --git a/src/connection/chroot.lisp b/src/connection/chroot.lisp
index f8c49a3..df6b85b 100644
--- a/src/connection/chroot.lisp
+++ b/src/connection/chroot.lisp
@@ -35,9 +35,9 @@ for example, such that we don't see it."
(defmethod establish-connection ((type (eql :chroot)) remaining &key into)
(establish-connection (if (and (lisp-connection-p)
- (can-chroot)
- (can-probably-fork))
- :chroot.fork
- :chroot.shell)
- remaining
- :into into))
+ (can-chroot)
+ (can-probably-fork))
+ :chroot.fork
+ :chroot.shell)
+ remaining
+ :into into))
diff --git a/src/connection/chroot/fork.lisp b/src/connection/chroot/fork.lisp
index d522304..d01faa5 100644
--- a/src/connection/chroot/fork.lisp
+++ b/src/connection/chroot/fork.lisp
@@ -18,7 +18,7 @@
(in-package :consfigurator.connection.chroot.fork)
(named-readtables:in-readtable :consfigurator)
#+sbcl (eval-when (:compile-toplevel :load-toplevel :execute)
- (require "sb-posix"))
+ (require "sb-posix"))
;; use only implementation-specific fork and waitpid calls to avoid thread
;; woes. chroot(2), however, should be okay.
@@ -44,7 +44,7 @@
;; bind mount but we might be the root Lisp, in which case we don't have a
;; cache to bind mount in. use chroot.shell connection to upload?
(mapc #'force-output
- (list *standard-output* *error-output* *debug-io* *terminal-io*))
+ (list *standard-output* *error-output* *debug-io* *terminal-io*))
(let ((child (fork)))
(case child
;; note that SB-POSIX:FORK can only return >=0
@@ -52,35 +52,35 @@
(error "fork(2) failed"))
(0
(handler-case
- (progn
- ;; TODO either (reset-data-sources), or bind a restart to convert
- ;; data source errors into failed-change (or ignore them? or
- ;; what?), as they may or may not be available inside the chroot,
- ;; depending on whether the data source code needs to read files
- ;; outside of the chroot or already has the data cached, a socket
- ;; open etc.
- (mapc #'clear-input
- (list *standard-input* *debug-io* *terminal-io*))
- (unless (zerop (chroot into))
- (error "chroot(2) failed; are you root?"))
- ;; chdir, else our current working directory is a pointer to
- ;; something outside the chroot
- (uiop:chdir "/")
- ;; it would be nice to reenter Consfigurator's primary loop by
- ;; just calling (return-from establish-connection
- ;; (establish-connection :local)) here, but we need to kill off
- ;; the child afterwards, rather than returning to the child's
- ;; REPL or whatever else
- (continue-deploy* remaining)
- (uiop:quit 0))
- (serious-condition (c)
- (format *error-output* ":CHROOT.FORK child failed: ~A~%" c)
- (uiop:quit 2))))
+ (progn
+ ;; TODO either (reset-data-sources), or bind a restart to convert
+ ;; data source errors into failed-change (or ignore them? or
+ ;; what?), as they may or may not be available inside the chroot,
+ ;; depending on whether the data source code needs to read files
+ ;; outside of the chroot or already has the data cached, a socket
+ ;; open etc.
+ (mapc #'clear-input
+ (list *standard-input* *debug-io* *terminal-io*))
+ (unless (zerop (chroot into))
+ (error "chroot(2) failed; are you root?"))
+ ;; chdir, else our current working directory is a pointer to
+ ;; something outside the chroot
+ (uiop:chdir "/")
+ ;; it would be nice to reenter Consfigurator's primary loop by
+ ;; just calling (return-from establish-connection
+ ;; (establish-connection :local)) here, but we need to kill off
+ ;; the child afterwards, rather than returning to the child's
+ ;; REPL or whatever else
+ (continue-deploy* remaining)
+ (uiop:quit 0))
+ (serious-condition (c)
+ (format *error-output* ":CHROOT.FORK child failed: ~A~%" c)
+ (uiop:quit 2))))
(t
(multiple-value-bind (_ status) (waitpid child 0)
- (declare (ignore _))
- (unless (zerop status)
- ;; TODO instead of parsing the status ourselves here, maybe we can
- ;; call the various C macros for parsing the status in wait(2)
- (error ":CHROOT.FORK child failed, status #x~(~4,'0X~)" status)))
+ (declare (ignore _))
+ (unless (zerop status)
+ ;; TODO instead of parsing the status ourselves here, maybe we can
+ ;; call the various C macros for parsing the status in wait(2)
+ (error ":CHROOT.FORK child failed, status #x~(~4,'0X~)" status)))
nil))))
diff --git a/src/connection/chroot/shell.lisp b/src/connection/chroot/shell.lisp
index 5ed87fc..3d75fbf 100644
--- a/src/connection/chroot/shell.lisp
+++ b/src/connection/chroot/shell.lisp
@@ -29,9 +29,9 @@
(defmethod connection-shell-wrap ((connection shell-chroot-connection) cmd)
(format nil "chroot ~A sh -c ~A"
- (escape-sh-token (slot-value connection 'root))
- (escape-sh-token cmd)))
+ (escape-sh-token (slot-value connection 'root))
+ (escape-sh-token cmd)))
(defmethod connection-upload ((connection shell-chroot-connection) from to)
(mrun "cp" from (merge-pathnames to (ensure-directory-pathname
- (slot-value connection 'root)))))
+ (slot-value connection 'root)))))
diff --git a/src/connection/local.lisp b/src/connection/local.lisp
index a689881..68705b0 100644
--- a/src/connection/local.lisp
+++ b/src/connection/local.lisp
@@ -37,8 +37,8 @@ root Lisp is running on, as the root Lisp's uid."))
(multiple-value-bind (output _ exit-code)
;; call sh(1) so we know we'll get POSIX
(run-program `("sh" "-c" ,shell-cmd)
- :input input :output :string
- :error-output :output :ignore-error-status t)
+ :input input :output :string
+ :error-output :output :ignore-error-status t)
(declare (ignore _))
(values output exit-code)))
@@ -46,25 +46,25 @@ root Lisp is running on, as the root Lisp's uid."))
(read-file-string path))
(defmethod connection-writefile ((connection local-connection)
- path
- content
- mode)
+ path
+ content
+ mode)
;; we cannot use UIOP:WITH-TEMPORARY-FILE etc., because those do not ensure
;; the file is only readable by us, and we might be writing a secret key
(with-remote-temporary-file
(temp :connection connection
- :directory (pathname-directory-pathname path))
+ :directory (pathname-directory-pathname path))
(run-program `("chmod" ,(format nil "~O" mode) ,temp))
(etypecase content
(string
(with-open-file (stream temp :direction :output :if-exists :supersede)
- (write-string content stream)))
+ (write-string content stream)))
(stream
(let ((type (stream-element-type content)))
- (with-open-file (stream temp :direction :output
- :if-exists :supersede
- :element-type type)
- (copy-stream-to-stream content stream :element-type type)))))
+ (with-open-file (stream temp :direction :output
+ :if-exists :supersede
+ :element-type type)
+ (copy-stream-to-stream content stream :element-type type)))))
(run-program `("mv" ,temp ,path))))
(defmethod connection-upload ((connection local-connection) from to)
diff --git a/src/connection/sbcl.lisp b/src/connection/sbcl.lisp
index 4ed465c..2cc73a6 100644
--- a/src/connection/sbcl.lisp
+++ b/src/connection/sbcl.lisp
@@ -37,15 +37,15 @@
(multiple-value-bind (program forms)
(continue-deploy*-program remaining)
(multiple-value-bind (out err exit)
- (run :may-fail :input program
- "sbcl" "--noinform" "--noprint"
- "--disable-debugger"
- "--no-sysinit" "--no-user-init")
+ (run :may-fail :input program
+ "sbcl" "--noinform" "--noprint"
+ "--disable-debugger"
+ "--no-sysinit" "--no-user-init")
(inform t "done." :fresh-line nil)
(unless (zerop exit)
- ;; print FORMS not PROGRAM because latter might contain sudo passwords
- (error "~%~%Remote Lisp failed; we sent~%~%~A~%~%and stderr was:~%~A"
- forms err))
+ ;; print FORMS not PROGRAM because latter might contain sudo passwords
+ (error "~%~%Remote Lisp failed; we sent~%~%~A~%~%and stderr was:~%~A"
+ forms err))
(inform t " Output was:" :fresh-line nil)
(with-indented-inform (inform t (lines out)))))
nil)
diff --git a/src/connection/shell-wrap.lisp b/src/connection/shell-wrap.lisp
index dd27f92..6c70210 100644
--- a/src/connection/shell-wrap.lisp
+++ b/src/connection/shell-wrap.lisp
@@ -28,28 +28,28 @@
(defmethod connection-readfile ((c shell-wrap-connection) path)
(multiple-value-bind (out exit)
(let ((path (escape-sh-token path)))
- (connection-run c #?"test -r ${path} && cat ${path}" nil))
+ (connection-run c #?"test -r ${path} && cat ${path}" nil))
(if (zerop exit) out (error "File ~S not readable" path))))
(defmethod connection-writefile ((conn shell-wrap-connection)
- path
- content
- mode)
+ path
+ content
+ mode)
(with-remote-temporary-file
(temp :connection conn :directory (pathname-directory-pathname path))
;; TODO do we want a CONNECTION-ERROR condition to tidy this up?
(multiple-value-bind (out exit)
- (connection-run conn
- (format nil "chmod ~O ~A" mode
- (escape-sh-token temp))
- nil)
+ (connection-run conn
+ (format nil "chmod ~O ~A" mode
+ (escape-sh-token temp))
+ nil)
(unless (zerop exit) (error "Failed to chmod ~A: ~A" temp out)))
(multiple-value-bind (out exit)
- (connection-run conn #?"cat >${temp}" content)
+ (connection-run conn #?"cat >${temp}" content)
(unless (zerop exit) (error "Failed to write ~A: ~A" temp out)))
(multiple-value-bind (out exit)
- (connection-run
- conn
- #?"mv ${(escape-sh-token temp)} ${(escape-sh-token path)}"
- nil)
+ (connection-run
+ conn
+ #?"mv ${(escape-sh-token temp)} ${(escape-sh-token path)}"
+ nil)
(unless (zerop exit) (error "Failed to write ~A: ~A" path out)))))
diff --git a/src/connection/ssh.lisp b/src/connection/ssh.lisp
index 2098585..5b89e27 100644
--- a/src/connection/ssh.lisp
+++ b/src/connection/ssh.lisp
@@ -19,9 +19,9 @@
(named-readtables:in-readtable :consfigurator)
(defmethod establish-connection ((type (eql :ssh)) remaining
- &key
- (hop (get-hostname))
- user)
+ &key
+ (hop (get-hostname))
+ user)
(declare (ignore remaining))
(informat 1 "~&Establishing SSH connection to ~A" hop)
(mrun "ssh" "-fN" hop)
@@ -44,8 +44,8 @@
(defmethod connection-shell-wrap ((connection ssh-connection) cmd)
;; wrap in 'sh -c' in case the login shell is not POSIX
(format nil "ssh ~A ~A"
- (ssh-host connection)
- (escape-sh-token (format nil "sh -c ~A" (escape-sh-token cmd)))))
+ (ssh-host connection)
+ (escape-sh-token (format nil "sh -c ~A" (escape-sh-token cmd)))))
;; rsync it straight to to its destination so rsync can do incremental updates
(defmethod connection-upload ((c ssh-connection) from to)
diff --git a/src/connection/sudo.lisp b/src/connection/sudo.lisp
index dc1bf58..c0e8f02 100644
--- a/src/connection/sudo.lisp
+++ b/src/connection/sudo.lisp
@@ -47,30 +47,30 @@
(defmethod preprocess-connection-args ((type (eql :sudo)) &key as (to "root"))
(list :sudo
- :user to
- :password (and
- as
- (destructuring-bind (user host)
- (split-string as :separator "@")
- (get-data-protected-string
- (strcat "--user-passwd--" host) user)))))
+ :user to
+ :password (and
+ as
+ (destructuring-bind (user host)
+ (split-string as :separator "@")
+ (get-data-protected-string
+ (strcat "--user-passwd--" host) user)))))
(defmethod establish-connection ((type (eql :sudo))
- remaining
- &key
- user
- password)
+ remaining
+ &key
+ user
+ password)
(declare (ignore remaining))
(informat 1 "~&Establishing sudo connection to ~A" user)
(make-instance 'sudo-connection
- :user user
- ;; we'll send the password followed by ^M, then the real
- ;; stdin. use CODE-CHAR in this way so that we can be sure
- ;; ASCII ^M is what will get emitted.
- :password (and password
- (make-passphrase
- (strcat (passphrase password)
- (string (code-char 13)))))))
+ :user user
+ ;; we'll send the password followed by ^M, then the real
+ ;; stdin. use CODE-CHAR in this way so that we can be sure
+ ;; ASCII ^M is what will get emitted.
+ :password (and password
+ (make-passphrase
+ (strcat (passphrase password)
+ (string (code-char 13)))))))
(defclass sudo-connection (shell-wrap-connection)
((user
@@ -85,8 +85,8 @@
;; wrap in sh -c so that it is more likely we are either asked for a
;; password for all our commands or not asked for one for any
(format nil "sudo -HkS --prompt=\"\" --user=~A sh -c ~A"
- (slot-value connection 'user)
- (escape-sh-token (strcat "cd \"$HOME\"; " cmd))))
+ (slot-value connection 'user)
+ (escape-sh-token (strcat "cd \"$HOME\"; " cmd))))
(defmethod connection-run ((c sudo-connection) cmd (input null))
(call-next-method c cmd (get-sudo-password c)))
@@ -96,17 +96,17 @@
(defmethod connection-run ((connection sudo-connection) cmd (input stream))
(call-next-method connection
- cmd
- (if-let ((password (get-sudo-password connection)))
- (make-concatenated-stream
- (if (subtypep (stream-element-type input) 'character)
- (make-string-input-stream password)
- (babel-streams:make-in-memory-input-stream
- (babel:string-to-octets
- password :encoding :UTF-8)
- :element-type (stream-element-type input)))
- input)
- input)))
+ cmd
+ (if-let ((password (get-sudo-password connection)))
+ (make-concatenated-stream
+ (if (subtypep (stream-element-type input) 'character)
+ (make-string-input-stream password)
+ (babel-streams:make-in-memory-input-stream
+ (babel:string-to-octets
+ password :encoding :UTF-8)
+ :element-type (stream-element-type input)))
+ input)
+ input)))
(defmethod connection-upload ((c sudo-connection) from to)
(connection-run c #?"cp ${from} ${to}" nil))
diff --git a/src/data.lisp b/src/data.lisp
index f63cd5b..ff21f1e 100644
--- a/src/data.lisp
+++ b/src/data.lisp
@@ -92,8 +92,8 @@ sources are not expected to be available outside of the root Lisp."))
(define-condition missing-data-source (error)
((text :initarg :text :reader missing-data-source-text))
(:report (lambda (condition stream)
- (format stream "Missing data source: ~A"
- (missing-data-source-text condition)))))
+ (format stream "Missing data source: ~A"
+ (missing-data-source-text condition)))))
(defvar *data-sources* nil "Known sources of prerequisite data.")
@@ -104,9 +104,9 @@ sources are not expected to be available outside of the root Lisp."))
"Register sources of prerequisite data.
This function is typically called in consfigs."
(when-let ((pair (and (not (find args *data-source-registrations*
- :test #'equal))
- (restart-case (apply #'register-data-source args)
- (skip-data-source () nil)))))
+ :test #'equal))
+ (restart-case (apply #'register-data-source args)
+ (skip-data-source () nil)))))
(push pair *data-sources*)
(push args *data-source-registrations*)))
@@ -118,7 +118,7 @@ This function is typically called in consfigs."
"Forget all data sources registered in this Lisp image.
This function is typically called at the REPL."
(setq *data-sources* nil
- *data-source-registrations* nil))
+ *data-source-registrations* nil))
(defun get-data-string (iden1 iden2)
"Return the content of an item of prerequisite data as a string.
@@ -145,17 +145,17 @@ This function is called by property :APPLY and :UNAPPLY subroutines."
;; else, look in local cache -- note that this won't exist in the root
;; Lisp, but only if we're a Lisp started up by a connection
(if-let ((local-cached
- (car (remove-if-not (lambda (c)
- (and (string= (first c) iden1)
- (string= (second c) iden2)))
- (sort-prerequisite-data-cache
- (get-local-cached-prerequisite-data))))))
+ (car (remove-if-not (lambda (c)
+ (and (string= (first c) iden1)
+ (string= (second c) iden2)))
+ (sort-prerequisite-data-cache
+ (get-local-cached-prerequisite-data))))))
(let ((file (apply #'local-data-pathname local-cached)))
- (make-instance 'file-data
- :iden1 iden1
- :iden2 iden2
- :file file
- :mime (try-get-file-mime-type file)))
+ (make-instance 'file-data
+ :iden1 iden1
+ :iden2 iden2
+ :file file
+ :mime (try-get-file-mime-type file)))
(error "Could not provide prerequisite data ~S | ~S" iden1 iden2))))
(defmethod %get-data-stream ((data string-data))
@@ -165,7 +165,7 @@ This function is called by property :APPLY and :UNAPPLY subroutines."
(defmethod %get-data-stream ((data file-data))
(open (data-file data) :direction :input
- :element-type '(unsigned-byte 8)))
+ :element-type '(unsigned-byte 8)))
(defmethod %get-data-string ((data string-data))
(data-string data))
@@ -175,71 +175,71 @@ This function is called by property :APPLY and :UNAPPLY subroutines."
(defun query-data-sources (iden1 iden2)
(flet ((make-thunk (v iden1 iden2)
- (lambda ()
- (funcall v iden1 iden2))))
+ (lambda ()
+ (funcall v iden1 iden2))))
(car (sort (loop for (ver . get) in *data-sources*
- for version = (funcall ver iden1 iden2)
- when version
- collect (cons version (make-thunk get iden1 iden2)))
- (lambda (x y)
- (version> (car x) (car y)))))))
+ for version = (funcall ver iden1 iden2)
+ when version
+ collect (cons version (make-thunk get iden1 iden2)))
+ (lambda (x y)
+ (version> (car x) (car y)))))))
;; called by implementations of ESTABLISH-CONNECTION which start up remote
;; Lisp images
(defun upload-all-prerequisite-data (&optional (host *host*))
(macrolet ((highest-version-in-cache (cache)
- `(third (car (remove-if-not (lambda (c)
- (and (string= (first c) iden1)
- (string= (second c) iden2)))
- ,cache)))))
+ `(third (car (remove-if-not (lambda (c)
+ (and (string= (first c) iden1)
+ (string= (second c) iden2)))
+ ,cache)))))
(loop with *data-sources* = (cons (register-data-source :asdf)
- *data-sources*)
-
- with sorted-local-cache = (sort-prerequisite-data-cache
- (get-local-cached-prerequisite-data))
- with sorted-remote-cache = (sort-prerequisite-data-cache
- (get-remote-cached-prerequisite-data))
- for (iden1 . iden2) in (getf (slot-value host 'hostattrs) :data)
-
- for highest-local-cached-version = (highest-version-in-cache
- sorted-local-cache)
- for highest-remote-cached-version = (highest-version-in-cache
- sorted-remote-cache)
- for (highest-source-version . highest-source)
- = (query-data-sources iden1 iden2)
-
- if (and highest-source-version
- (or (not highest-remote-cached-version)
- (version< highest-remote-cached-version
- highest-source-version)))
- do (connection-clear-data-cache iden1 iden2)
- (connection-upload-data (funcall highest-source))
- else if (and highest-local-cached-version
- (or (not highest-remote-cached-version)
- (version< highest-remote-cached-version
- highest-local-cached-version)))
- do (let ((file (local-data-pathname
- iden1
- iden2
- highest-local-cached-version)))
- (connection-clear-data-cache iden1 iden2)
- (connection-upload-data
- (make-instance 'file-data
- :iden1 iden1
- :iden2 iden2
- :version highest-local-cached-version
- :file file
- :mime (try-get-file-mime-type file))))
- else unless highest-remote-cached-version
- do (error "Could not provide prerequisite data ~S | ~S"
- iden1 iden2))))
+ *data-sources*)
+
+ with sorted-local-cache = (sort-prerequisite-data-cache
+ (get-local-cached-prerequisite-data))
+ with sorted-remote-cache = (sort-prerequisite-data-cache
+ (get-remote-cached-prerequisite-data))
+ for (iden1 . iden2) in (getf (slot-value host 'hostattrs) :data)
+
+ for highest-local-cached-version = (highest-version-in-cache
+ sorted-local-cache)
+ for highest-remote-cached-version = (highest-version-in-cache
+ sorted-remote-cache)
+ for (highest-source-version . highest-source)
+ = (query-data-sources iden1 iden2)
+
+ if (and highest-source-version
+ (or (not highest-remote-cached-version)
+ (version< highest-remote-cached-version
+ highest-source-version)))
+ do (connection-clear-data-cache iden1 iden2)
+ (connection-upload-data (funcall highest-source))
+ else if (and highest-local-cached-version
+ (or (not highest-remote-cached-version)
+ (version< highest-remote-cached-version
+ highest-local-cached-version)))
+ do (let ((file (local-data-pathname
+ iden1
+ iden2
+ highest-local-cached-version)))
+ (connection-clear-data-cache iden1 iden2)
+ (connection-upload-data
+ (make-instance 'file-data
+ :iden1 iden1
+ :iden2 iden2
+ :version highest-local-cached-version
+ :file file
+ :mime (try-get-file-mime-type file))))
+ else unless highest-remote-cached-version
+ do (error "Could not provide prerequisite data ~S | ~S"
+ iden1 iden2))))
(defun try-get-file-mime-type (file)
(handler-case (stripln (run-program
- (escape-sh-command (list "file" "-E"
- "--mime-type" "--brief"
- (unix-namestring file)))
- :output :string))
+ (escape-sh-command (list "file" "-E"
+ "--mime-type" "--brief"
+ (unix-namestring file)))
+ :output :string))
(subprocess-error () nil)))
(defun sort-prerequisite-data-cache (cache)
@@ -249,8 +249,8 @@ This function is called by property :APPLY and :UNAPPLY subroutines."
(destructuring-bind (last . rest)
(nreverse (mapcar #'string->filename segments))
(merge-pathnames last (reduce #'merge-pathnames
- (mapcar (lambda (s) (strcat s "/")) rest)
- :from-end t :initial-value root))))
+ (mapcar (lambda (s) (strcat s "/")) rest)
+ :from-end t :initial-value root))))
(defun local-data-pathname (&rest args)
(apply #'data-pathname (get-local-data-cache-dir) args))
@@ -262,18 +262,18 @@ This function is called by property :APPLY and :UNAPPLY subroutines."
"Wrapper around CONNECTION-UPLOAD to ensure it gets used only when
appropriate. Falls back to CONNECTION-WRITEFILE."
(if (and (subtypep (type-of (slot-value *connection* 'parent))
- 'consfigurator.connection.local:local-connection)
- (find-method #'connection-upload
- '()
- (mapcar #'class-of (list *connection* t t))
- nil))
+ 'consfigurator.connection.local:local-connection)
+ (find-method #'connection-upload
+ '()
+ (mapcar #'class-of (list *connection* t t))
+ nil))
(connection-upload *connection* from to)
(with-open-file (s from :element-type '(unsigned-byte 8))
- (connection-writefile *connection* to s #o077))))
+ (connection-writefile *connection* to s #o077))))
(defmethod connection-upload-data :around ((data data))
(when (subtypep (class-of *connection*)
- 'consfigurator.connection.local:local-connection)
+ 'consfigurator.connection.local:local-connection)
(error "Attempt to upload data to the root Lisp; this is not allowed"))
(with-slots (iden1 iden2 data-version) data
(let ((*dest* (remote-data-pathname iden1 iden2 data-version)))
@@ -288,14 +288,14 @@ appropriate. Falls back to CONNECTION-WRITEFILE."
(declare (special *dest*))
(let ((source (unix-namestring (data-file data))))
(if (string-prefix-p "text/" (data-mime data))
- (let ((dest (strcat (unix-namestring *dest*) ".gz")))
- (with-temporary-file (:pathname tmp)
- (run-program (strcat "gzip --rsyncable -c "
- (escape-sh-token source))
- :output tmp)
- (connection-try-upload tmp (unix-namestring dest))
- (mrun "gunzip" "--keep" dest)))
- (connection-try-upload source *dest*))))
+ (let ((dest (strcat (unix-namestring *dest*) ".gz")))
+ (with-temporary-file (:pathname tmp)
+ (run-program (strcat "gzip --rsyncable -c "
+ (escape-sh-token source))
+ :output tmp)
+ (connection-try-upload tmp (unix-namestring dest))
+ (mrun "gunzip" "--keep" dest)))
+ (connection-try-upload source *dest*))))
(defmethod connection-upload-data ((data string-data))
(declare (special *dest*))
@@ -304,13 +304,13 @@ appropriate. Falls back to CONNECTION-WRITEFILE."
(defun connection-clear-data-cache (iden1 iden2)
(let ((dir (ensure-directory-pathname (remote-data-pathname iden1 iden2))))
(mrun (strcat "rm -f "
- (unix-namestring (pathname-directory-pathname dir))
- "/*"))))
+ (unix-namestring (pathname-directory-pathname dir))
+ "/*"))))
(defun get-local-data-cache-dir ()
(ensure-directory-pathname
(strcat (or (getenv "XDG_CACHE_HOME") (strcat (getenv "HOME") "/.cache"))
- "/consfigurator/data")))
+ "/consfigurator/data")))
(defun get-local-cached-prerequisite-data ()
"Return a list of items of prerequisite data in the cache local to this Lisp
@@ -318,15 +318,15 @@ process, where each entry is of the form
'(iden1 iden2 version)."
(loop for dir in (subdirectories (get-local-data-cache-dir))
- nconc (loop for subdir in (subdirectories dir)
- nconc (loop for file in (directory-files subdir)
- collect
- (mapcar #'filename->string
- (list (lastcar
- (pathname-directory dir))
- (lastcar
- (pathname-directory subdir))
- (pathname-name file)))))))
+ nconc (loop for subdir in (subdirectories dir)
+ nconc (loop for file in (directory-files subdir)
+ collect
+ (mapcar #'filename->string
+ (list (lastcar
+ (pathname-directory dir))
+ (lastcar
+ (pathname-directory subdir))
+ (pathname-name file)))))))
(defun get-remote-data-cache-dir ()
(ensure-directory-pathname
@@ -340,11 +340,11 @@ of the current connection, where each entry is of the form
'(iden1 iden2 version)."
(mapcar (lambda (line)
- (mapcar #'filename->string (split-string line :separator "/")))
- (multiple-value-bind (out exit)
- (mrun :may-fail "find" (get-remote-data-cache-dir)
- "-type" "f" "-printf" "%P\\n")
- (and (zerop exit) (lines out)))))
+ (mapcar #'filename->string (split-string line :separator "/")))
+ (multiple-value-bind (out exit)
+ (mrun :may-fail "find" (get-remote-data-cache-dir)
+ "-type" "f" "-printf" "%P\\n")
+ (and (zerop exit) (lines out)))))
;; TODO unclear whether the need for this is a bug in trivial-macroexpand-all
(define-constant +continue-deploy*-program-implementation-specific+
@@ -372,10 +372,10 @@ chance of those passwords showing up in the clear in the Lisp debugger."
(defmethod print-object ((passphrase passphrase) stream)
(if *allow-printing-passphrases*
(format stream "#.~S"
- `(make-instance 'passphrase
- :passphrase ,(passphrase passphrase)))
+ `(make-instance 'passphrase
+ :passphrase ,(passphrase passphrase)))
(print-unreadable-object (passphrase stream)
- (format stream "PASSPHRASE")))
+ (format stream "PASSPHRASE")))
passphrase)
@@ -400,57 +400,57 @@ achieved by sending the return value of this function into a REPL's stdin."
Preprocessing must occur in the root Lisp."))
(flet ((wrap (forms)
- `(handler-bind
- (;; we can skip missing data sources because these are not
- ;; expected to be available outside of the root Lisp
- (missing-data-source
- (lambda (c)
- (declare (ignore c))
- (invoke-restart 'skip-data-source))))
- (let ((*consfigurator-debug-level* ,*consfigurator-debug-level*))
- ,@forms))))
+ `(handler-bind
+ (;; we can skip missing data sources because these are not
+ ;; expected to be available outside of the root Lisp
+ (missing-data-source
+ (lambda (c)
+ (declare (ignore c))
+ (invoke-restart 'skip-data-source))))
+ (let ((*consfigurator-debug-level* ,*consfigurator-debug-level*))
+ ,@forms))))
(let* ((intern-forms
- (loop for name in '("MISSING-DATA-SOURCE"
- "SKIP-DATA-SOURCE"
- "*CONSFIGURATOR-DEBUG-LEVEL*")
- collect
- `(export (intern ,name (find-package "CONSFIGURATOR"))
- (find-package "CONSFIGURATOR"))))
- (load-forms
- (loop for system
- in (slot-value (slot-value *host* 'propspec) 'systems)
- collect `(load
- ,(caddar
- (remove-if-not
- (lambda (d)
- (string= (car d) "--lisp-system")
- (string= (cadr d) (normalise-system system)))
- (slot-value *connection* 'cached-data))))))
- (forms `((make-package "CONSFIGURATOR")
- ;; Work around bug in CL-HEREDOC that cl-heredoc.asd must
- ;; be loaded for this package to be defined; this does not
- ;; work with ASDF:MONOLITHIC-CONCATENATE-SOURCE-OP, which
- ;; does not bundle the .asd files.
- (use-package :cl (make-package "CL-HEREDOC-SYSTEM"))
- ,@intern-forms
- (define-condition missing-data-source (error) ())
- (require "asdf")
- (let ((*standard-output* *error-output*))
- ,(wrap load-forms))
- ,(wrap `((%consfigure ',remaining-connections ,*host*))))))
+ (loop for name in '("MISSING-DATA-SOURCE"
+ "SKIP-DATA-SOURCE"
+ "*CONSFIGURATOR-DEBUG-LEVEL*")
+ collect
+ `(export (intern ,name (find-package "CONSFIGURATOR"))
+ (find-package "CONSFIGURATOR"))))
+ (load-forms
+ (loop for system
+ in (slot-value (slot-value *host* 'propspec) 'systems)
+ collect `(load
+ ,(caddar
+ (remove-if-not
+ (lambda (d)
+ (string= (car d) "--lisp-system")
+ (string= (cadr d) (normalise-system system)))
+ (slot-value *connection* 'cached-data))))))
+ (forms `((make-package "CONSFIGURATOR")
+ ;; Work around bug in CL-HEREDOC that cl-heredoc.asd must
+ ;; be loaded for this package to be defined; this does not
+ ;; work with ASDF:MONOLITHIC-CONCATENATE-SOURCE-OP, which
+ ;; does not bundle the .asd files.
+ (use-package :cl (make-package "CL-HEREDOC-SYSTEM"))
+ ,@intern-forms
+ (define-condition missing-data-source (error) ())
+ (require "asdf")
+ (let ((*standard-output* *error-output*))
+ ,(wrap load-forms))
+ ,(wrap `((%consfigure ',remaining-connections ,*host*))))))
(handler-case
- (with-standard-io-syntax
- (let ((*allow-printing-passphrases* t))
- ;; need line breaks in between so that packages exist before we
- ;; try to have remote Lisp read sexps containing symbols from
- ;; those packages
- (values
- (format nil "~A~%~{~A~^~%~}"
- +continue-deploy*-program-implementation-specific+
- (mapcar #'prin1-to-string forms))
- forms)))
- (print-not-readable (c)
- (error "The Lisp printer could not serialise ~A for
+ (with-standard-io-syntax
+ (let ((*allow-printing-passphrases* t))
+ ;; need line breaks in between so that packages exist before we
+ ;; try to have remote Lisp read sexps containing symbols from
+ ;; those packages
+ (values
+ (format nil "~A~%~{~A~^~%~}"
+ +continue-deploy*-program-implementation-specific+
+ (mapcar #'prin1-to-string forms))
+ forms)))
+ (print-not-readable (c)
+ (error "The Lisp printer could not serialise ~A for
transmission to the remote Lisp.
This is probably because your property application specification and/or static
@@ -461,7 +461,7 @@ hostattrs; see \"Pitfalls\" in the Consfigurator user manual.
If ~:*~A is a simple object then you may be able to resolve this by defining
a PRINT-OBJECT method for your class."
- (print-not-readable-object c)))))))
+ (print-not-readable-object c)))))))
(defun request-lisp-systems ()
"Request that all Lisp systems required by the host currently being deployed
diff --git a/src/data/asdf.lisp b/src/data/asdf.lisp
index 51ac344..67d405c 100644
--- a/src/data/asdf.lisp
+++ b/src/data/asdf.lisp
@@ -34,26 +34,26 @@
(defun asdf-data-source-check (iden1 system)
(when (and (string= iden1 "--lisp-system")
- (asdf:find-system system nil))
+ (asdf:find-system system nil))
(get-universal-time)))
(defun get-path-to-concatenated-system (iden1 system)
"Try to concatenate all the source code for SYSTEM, store it somewhere and
return the filename."
(let ((cache-dir (ensure-directory-pathname
- (strcat (or (getenv "XDG_CACHE_HOME")
- (strcat (getenv "HOME") "/.cache"))
- "/consfigurator/systems")))
- (op 'asdf:monolithic-concatenate-source-op)
- (co (asdf:find-component system nil)))
+ (strcat (or (getenv "XDG_CACHE_HOME")
+ (strcat (getenv "HOME") "/.cache"))
+ "/consfigurator/systems")))
+ (op 'asdf:monolithic-concatenate-source-op)
+ (co (asdf:find-component system nil)))
(ensure-directories-exist cache-dir)
(asdf:initialize-output-translations `(:output-translations
- (t ,cache-dir)
- :disable-cache
- :ignore-inherited-configuration))
+ (t ,cache-dir)
+ :disable-cache
+ :ignore-inherited-configuration))
(asdf:operate op co)
(make-instance 'file-data :file (asdf:output-file op co)
- :mime "text/plain"
- :iden1 iden1
- :iden2 system
- :version (get-universal-time))))
+ :mime "text/plain"
+ :iden1 iden1
+ :iden2 system
+ :version (get-universal-time))))
diff --git a/src/data/pgp.lisp b/src/data/pgp.lisp
index 51e8a2d..a6b9339 100644
--- a/src/data/pgp.lisp
+++ b/src/data/pgp.lisp
@@ -31,46 +31,46 @@
(defmethod register-data-source ((type (eql :pgp)) &key location)
(unless (file-exists-p location)
(error 'missing-data-source
- :text (format nil "Could not open ~A" location)))
+ :text (format nil "Could not open ~A" location)))
(let ((mod (file-write-date location))
- (cache (read-store location)))
+ (cache (read-store location)))
(labels ((update-cache ()
- (let ((new-mod (file-write-date location)))
- (when (> new-mod mod)
- (setq mod new-mod
- cache (read-store location)))))
- (check (iden1 iden2)
- (update-cache)
- (cadr (data-assoc iden1 iden2 cache)))
- (extract (iden1 iden2)
- (update-cache)
- (let ((data (data-assoc iden1 iden2 cache)))
- (make-instance 'string-data
- :iden1 iden1 :iden2 iden2
- :string (cddr data) :version (cadr data)))))
+ (let ((new-mod (file-write-date location)))
+ (when (> new-mod mod)
+ (setq mod new-mod
+ cache (read-store location)))))
+ (check (iden1 iden2)
+ (update-cache)
+ (cadr (data-assoc iden1 iden2 cache)))
+ (extract (iden1 iden2)
+ (update-cache)
+ (let ((data (data-assoc iden1 iden2 cache)))
+ (make-instance 'string-data
+ :iden1 iden1 :iden2 iden2
+ :string (cddr data) :version (cadr data)))))
(cons #'check #'extract))))
(defun read-store (location)
(handler-case
(read-from-string
(run-program
- (escape-sh-command (list "gpg" "--decrypt" (unix-namestring location)))
- :output :string))
+ (escape-sh-command (list "gpg" "--decrypt" (unix-namestring location)))
+ :output :string))
(subprocess-error (error)
(error 'missing-data-source
- :text (format nil "While attempt to decrypt, gpg exited with ~A"
- (uiop:subprocess-error-code error))))))
+ :text (format nil "While attempt to decrypt, gpg exited with ~A"
+ (uiop:subprocess-error-code error))))))
(defun put-store (location data)
(run-program (list "gpg" "--encrypt")
- :input (make-string-input-stream (prin1-to-string data))
- :output (unix-namestring location)))
+ :input (make-string-input-stream (prin1-to-string data))
+ :output (unix-namestring location)))
(defun data-assoc (iden1 iden2 data)
(assoc (cons iden1 iden2) data
- :test (lambda (x y)
- (and (string= (car x) (car y))
- (string= (cdr x) (cdr y))))))
+ :test (lambda (x y)
+ (and (string= (car x) (car y))
+ (string= (cdr x) (cdr y))))))
(defun get-data (location iden1 iden2)
"Fetch a piece of prerequisite data.
@@ -83,9 +83,9 @@ Useful at the REPL."
Useful at the REPL."
(let ((data (delete-if
- (lambda (d)
- (and (string= (caar d) iden1) (string= (cdar d) iden2)))
- (and (file-exists-p location) (read-store location)))))
+ (lambda (d)
+ (and (string= (caar d) iden1) (string= (cdar d) iden2)))
+ (and (file-exists-p location) (read-store location)))))
(push (cons (cons iden1 iden2) (cons (get-universal-time) val)) data)
(put-store location data)))
diff --git a/src/deployment.lisp b/src/deployment.lisp
index 0a200e3..a895807 100644
--- a/src/deployment.lisp
+++ b/src/deployment.lisp
@@ -27,29 +27,29 @@ Assumes arguments to connections in CONNECTIONS have been both normalised and
preprocessed."
(labels
((apply-*host*-propspec ()
- (let ((propapp (eval-propspec (host-propspec *host*))))
- (assert-connection-supports (propapptype propapp))
- (propappapply propapp)))
+ (let ((propapp (eval-propspec (host-propspec *host*))))
+ (assert-connection-supports (propapptype propapp))
+ (propappapply propapp)))
(connect (connections)
- (destructuring-bind ((type . args) . remaining) connections
- ;; implementations of ESTABLISH-CONNECTION which call
- ;; CONTINUE-DEPLOY* or CONTINUE-DEPLOY*-PROGRAM return nil to us
- (when-let ((*connection*
- (apply #'establish-connection type remaining args)))
- (if remaining
- (connect remaining)
- (apply-*host*-propspec))
- (connection-teardown *connection*)))))
+ (destructuring-bind ((type . args) . remaining) connections
+ ;; implementations of ESTABLISH-CONNECTION which call
+ ;; CONTINUE-DEPLOY* or CONTINUE-DEPLOY*-PROGRAM return nil to us
+ (when-let ((*connection*
+ (apply #'establish-connection type remaining args)))
+ (if remaining
+ (connect remaining)
+ (apply-*host*-propspec))
+ (connection-teardown *connection*)))))
(let ((*host* (preprocess-host host)))
(cond
- ((and connections (or *connection* (eq :local (caar connections))))
- (connect connections))
- (connections
- (connect (cons '(:local) connections)))
- (*connection*
- (apply-*host*-propspec))
- (t
- (connect '((:local))))))))
+ ((and connections (or *connection* (eq :local (caar connections))))
+ (connect connections))
+ (connections
+ (connect (cons '(:local) connections)))
+ (*connection*
+ (apply-*host*-propspec))
+ (t
+ (connect '((:local))))))))
(defun deploy* (connections host &optional additional-properties)
"Execute the deployment which is defined by the pair (CONNECTIONS . HOST),
@@ -61,10 +61,10 @@ DEPLOY, DEPLOY-THESE, and the function definitions established by DEFDEPLOY,
DEFDEPLOY-THESE, etc., rather than calling this function directly. However,
code which programmatically constructs deployments will need to call this."
(%consfigure (preprocess-connections connections)
- (if additional-properties
- (%union-propspec-into-host (shallow-copy-host host)
- additional-properties)
- host)))
+ (if additional-properties
+ (%union-propspec-into-host (shallow-copy-host host)
+ additional-properties)
+ host)))
(defun deploy-these* (connections host &optional properties)
"Like DEPLOY*, but replace the properties of HOST with PROPERTIES.
@@ -75,10 +75,10 @@ by PROPERTIES can override the host's usual static informational attributes,
in the same way that later entries in the list of properties specified in
DEFHOST forms can override earlier entries (see DEFHOST's docstring)."
(%consfigure (preprocess-connections connections)
- (if properties
- (%replace-propspec-into-host (shallow-copy-host host)
- properties)
- host)))
+ (if properties
+ (%replace-propspec-into-host (shallow-copy-host host)
+ properties)
+ host)))
(defun continue-deploy* (remaining-connections)
"Complete the work of an enclosing call to DEPLOY* or DEPLOY-THESE*.
@@ -113,13 +113,13 @@ specification may retrieve existing hostattrs, but should not set any new
ones (not to be confused with how the :HOSTATTRS subroutines of properties in
ADDITIONAL-PROPERTIES may set additional hostattrs)."
(once-only ((host (if (stringp host)
- `(make-host :hostattrs (list :hostname (list ,host)))
- host)))
+ `(make-host :hostattrs (list :hostname (list ,host)))
+ host)))
`(deploy* ',connections
- ,host
- (let ((*host* (shallow-copy-host ,host)))
- (make-propspec
- :propspec (props eseqprops ,@additional-properties))))))
+ ,host
+ (let ((*host* (shallow-copy-host ,host)))
+ (make-propspec
+ :propspec (props eseqprops ,@additional-properties))))))
(defmacro deploy-these (connections host &body properties)
"Like DEPLOY, except apply each of the properties specified by PROPERTIES,
@@ -144,13 +144,13 @@ may retrieve existing hostattrs, but should not set any new ones (not to be
confused with how the :HOSTATTRS subroutines of properties in PROPERTIES may
set additional hostattrs)."
(once-only ((host (if (stringp host)
- `(make-host :hostattrs (list :hostname (list ,host)))
- host)))
+ `(make-host :hostattrs (list :hostname (list ,host)))
+ host)))
`(deploy-these* ',connections
- ,host
- (let ((*host* (shallow-copy-host ,host)))
- (make-propspec
- :propspec (props eseqprops ,@properties))))))
+ ,host
+ (let ((*host* (shallow-copy-host ,host)))
+ (make-propspec
+ :propspec (props eseqprops ,@properties))))))
(defmacro defdeploy (name (connections host) &body additional-properties)
"Define a function which does (DEPLOY CONNECTIONS HOST ADDITIONAL-PROPERTIES).
@@ -173,11 +173,11 @@ Useful to have one host act a controller, applying properties to other hosts.
Also useful to set up VMs, chroots, disk images etc. on localhost."
(:preprocess
(list (preprocess-connections connections)
- (preprocess-host
- (if additional-properties
- (%union-propspec-into-host (shallow-copy-host host)
- additional-properties)
- host))))
+ (preprocess-host
+ (if additional-properties
+ (%union-propspec-into-host (shallow-copy-host host)
+ additional-properties)
+ host))))
(:hostattrs
(declare (ignore connections additional-properties))
(%propagate-hostattrs host))
@@ -191,8 +191,8 @@ PROPERTIES, and not the host's usual properties, unless they also appear in
PROPERTIES, like DEPLOY-THESE."
(:preprocess
(list (preprocess-connections connections)
- (preprocess-host
- (%replace-propspec-into-host (shallow-copy-host host) properties))))
+ (preprocess-host
+ (%replace-propspec-into-host (shallow-copy-host host) properties))))
(:hostattrs
(declare (ignore connections properties))
(%propagate-hostattrs host))
@@ -202,8 +202,8 @@ PROPERTIES, like DEPLOY-THESE."
(defun preprocess-connections (connections)
(loop for connection in (ensure-cons connections)
- collect (apply #'preprocess-connection-args
- (ensure-cons connection))))
+ collect (apply #'preprocess-connection-args
+ (ensure-cons connection))))
(defun %propagate-hostattrs (host)
(dolist (system (propspec-systems (host-propspec host)))
diff --git a/src/host.lisp b/src/host.lisp
index e31cdf3..7bb4669 100644
--- a/src/host.lisp
+++ b/src/host.lisp
@@ -45,8 +45,8 @@
(defmethod shallow-copy-host ((host host))
(make-instance (type-of host)
- :hostattrs (copy-list (hostattrs host))
- :propspec (host-propspec host)))
+ :hostattrs (copy-list (hostattrs host))
+ :propspec (host-propspec host)))
(defmacro with-preserve-hostattrs (&body forms)
"Evaluate FORMS then throw away any newly added hostattrs.
@@ -69,15 +69,15 @@ values higher up the call stack."))
(defmethod preprocess-host ((host unpreprocessed-host))
(let ((*host* (make-instance
- 'preprocessed-host
- :hostattrs (copy-list (hostattrs host))
- :propspec (preprocess-propspec (host-propspec host)))))
+ 'preprocessed-host
+ :hostattrs (copy-list (hostattrs host))
+ :propspec (preprocess-propspec (host-propspec host)))))
(propappattrs (eval-propspec (host-propspec *host*)))
*host*))
(defun make-host (&key hostattrs (propspec (make-propspec)))
(make-instance 'unpreprocessed-host
- :hostattrs hostattrs :propspec propspec))
+ :hostattrs hostattrs :propspec propspec))
(defun make-child-host (&key hostattrs propspec)
"Make a host object to represent a chroot, container or the like.
@@ -89,9 +89,9 @@ Called by properties which set up such subhosts, like CHROOT:OS-BOOTSTRAPPED."
(defmethod print-object ((host host) stream)
(format stream "#.~S" `(make-instance
- ',(type-of host)
- :hostattrs ',(slot-value host 'hostattrs)
- :propspec ,(slot-value host 'propspec)))
+ ',(type-of host)
+ :hostattrs ',(slot-value host 'hostattrs)
+ :propspec ,(slot-value host 'propspec)))
host)
;; return values of the following two functions share structure, and thus are
@@ -101,8 +101,8 @@ Called by properties which set up such subhosts, like CHROOT:OS-BOOTSTRAPPED."
(defmethod %union-propspec-into-host
((host unpreprocessed-host) (propspec propspec))
(make-instance 'unpreprocessed-host
- :hostattrs (hostattrs host)
- :propspec (append-propspecs (host-propspec host) propspec)))
+ :hostattrs (hostattrs host)
+ :propspec (append-propspecs (host-propspec host) propspec)))
(defmethod %replace-propspec-into-host
((host unpreprocessed-host) (propspec unpreprocessed-propspec))
@@ -110,8 +110,8 @@ Called by properties which set up such subhosts, like CHROOT:OS-BOOTSTRAPPED."
;; value to have all the hostattrs it would have were PROPSPEC not to be
;; substituted in
(make-instance 'unpreprocessed-host
- :hostattrs (hostattrs (preprocess-host host))
- :propspec propspec))
+ :hostattrs (hostattrs (preprocess-host host))
+ :propspec propspec))
(defmacro defhost (hostname (&key deploy) &body properties)
"Define a host with hostname HOSTNAME and properties PROPERTIES.
@@ -142,16 +142,16 @@ entries."
(etypecase hostname
(string (setq hostname-sym (intern hostname)))
(symbol (setq hostname-sym hostname
- hostname (string-downcase (symbol-name hostname)))))
+ hostname (string-downcase (symbol-name hostname)))))
(push hostname (getf attrs :hostname))
(when (stringp (car properties))
(push (pop properties) (getf attrs :desc)))
`(progn
(declaim (type host ,hostname-sym))
(defparameter ,hostname-sym
- (make-host :hostattrs ',attrs
- :propspec (make-propspec
- :propspec (props seqprops ,@properties)))
- ,(car (getf attrs :desc)))
+ (make-host :hostattrs ',attrs
+ :propspec (make-propspec
+ :propspec (props seqprops ,@properties)))
+ ,(car (getf attrs :desc)))
,@(and deploy
- `((defdeploy ,hostname-sym (,deploy ,hostname-sym)))))))
+ `((defdeploy ,hostname-sym (,deploy ,hostname-sym)))))))
diff --git a/src/package.lisp b/src/package.lisp
index f3b3662..16eaaea 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -4,180 +4,180 @@
(:use #:cl #:alexandria)
(:local-nicknames (#:re #:cl-ppcre))
(:shadowing-import-from #:uiop
- #:strcat
- #:string-prefix-p
- #:split-string
- #:last-char
- #:escape-sh-command
- #:escape-sh-token
- #:run-program
- #:read-file-string
- #:copy-stream-to-stream
- #:subprocess-error
- #:stripln
- #:unix-namestring
- #:pathname-directory-pathname
- #:with-temporary-file
- #:ensure-directory-pathname
- #:getenv
- #:subdirectories
- #:directory-files
- #:file-exists-p
- #:with-current-directory)
+ #:strcat
+ #:string-prefix-p
+ #:split-string
+ #:last-char
+ #:escape-sh-command
+ #:escape-sh-token
+ #:run-program
+ #:read-file-string
+ #:copy-stream-to-stream
+ #:subprocess-error
+ #:stripln
+ #:unix-namestring
+ #:pathname-directory-pathname
+ #:with-temporary-file
+ #:ensure-directory-pathname
+ #:getenv
+ #:subdirectories
+ #:directory-files
+ #:file-exists-p
+ #:with-current-directory)
(:export ;; re-export from UIOP
- #:strcat
- #:string-prefix-p
- #:split-string
- #:last-char
- #:escape-sh-command
- #:escape-sh-token
- #:run-program
- #:read-file-string
- #:copy-stream-to-stream
- #:subprocess-error
- #:stripln
- #:unix-namestring
- #:pathname-directory-pathname
- #:with-temporary-file
- #:ensure-directory-pathname
- #:getenv
- #:subdirectories
- #:directory-files
- #:file-exists-p
- #:with-current-directory
+ #:strcat
+ #:string-prefix-p
+ #:split-string
+ #:last-char
+ #:escape-sh-command
+ #:escape-sh-token
+ #:run-program
+ #:read-file-string
+ #:copy-stream-to-stream
+ #:subprocess-error
+ #:stripln
+ #:unix-namestring
+ #:pathname-directory-pathname
+ #:with-temporary-file
+ #:ensure-directory-pathname
+ #:getenv
+ #:subdirectories
+ #:directory-files
+ #:file-exists-p
+ #:with-current-directory
- ;; util.lisp
- #:lines
- #:unlines
- #:noop
- #:symbol-named
- #:memstring=
- #:plist-to-cmd-args
+ ;; util.lisp
+ #:lines
+ #:unlines
+ #:noop
+ #:symbol-named
+ #:memstring=
+ #:plist-to-cmd-args
- #:*consfigurator-debug-level*
- #:with-indented-inform
- #:inform
- #:informat
+ #:*consfigurator-debug-level*
+ #:with-indented-inform
+ #:inform
+ #:informat
- #:version<
- #:version>
- #:version<=
- #:version>=
+ #:version<
+ #:version>
+ #:version<=
+ #:version>=
- #:string->filename
- #:filename->string
+ #:string->filename
+ #:filename->string
- ;; connection.lisp
- #:establish-connection
- #:preprocess-connection-args
- #:connection
- #:lisp-connection
- #:posix-connection
- #:lisp-connection-p
- #:connection-run
- #:connection-readfile
- #:connection-writefile
- #:connection-upload
- #:connection-teardown
+ ;; connection.lisp
+ #:establish-connection
+ #:preprocess-connection-args
+ #:connection
+ #:lisp-connection
+ #:posix-connection
+ #:lisp-connection-p
+ #:connection-run
+ #:connection-readfile
+ #:connection-writefile
+ #:connection-upload
+ #:connection-teardown
- #:run
- #:mrun
- #:with-remote-temporary-file
- #:run-failed
- #:runlines
- #:test
- #:readfile
- #:writefile
+ #:run
+ #:mrun
+ #:with-remote-temporary-file
+ #:run-failed
+ #:runlines
+ #:test
+ #:readfile
+ #:writefile
- ;; property.lisp
- #:propattrs
- #:propunapply
- #:collapse-types
- #:propapptype
- #:propappdesc
- #:propappattrs
- #:propappcheck
- #:propappapply
- #:propappunapply
- #:ignoring-hostattrs
- #:defprop
- #:defpropspec
- #:defproplist
- #:inapplicable-property
- #:get-hostattrs
- #:get-hostattrs-car
- #:get-parent-hostattrs
- #:get-parent-hostattrs-car
- #:push-hostattrs
- #:pushnew-hostattrs
- #:get-hostname
- #:require-data
- #:failed-change
- #:assert-euid-root
- #:assert-connection-supports
- #:call-with-os
+ ;; property.lisp
+ #:propattrs
+ #:propunapply
+ #:collapse-types
+ #:propapptype
+ #:propappdesc
+ #:propappattrs
+ #:propappcheck
+ #:propappapply
+ #:propappunapply
+ #:ignoring-hostattrs
+ #:defprop
+ #:defpropspec
+ #:defproplist
+ #:inapplicable-property
+ #:get-hostattrs
+ #:get-hostattrs-car
+ #:get-parent-hostattrs
+ #:get-parent-hostattrs-car
+ #:push-hostattrs
+ #:pushnew-hostattrs
+ #:get-hostname
+ #:require-data
+ #:failed-change
+ #:assert-euid-root
+ #:assert-connection-supports
+ #:call-with-os
- ;; propspec.lisp
- #:in-consfig
- #:propspec-systems
- #:propspec-props
- #:make-propspec
- #:append-propspecs
- #:define-function-property-combinator
- #:seqprops
- #:eseqprops
- #:with-requirements
- #:silent-seqprops
- #:unapply
- #:on-change
+ ;; propspec.lisp
+ #:in-consfig
+ #:propspec-systems
+ #:propspec-props
+ #:make-propspec
+ #:append-propspecs
+ #:define-function-property-combinator
+ #:seqprops
+ #:eseqprops
+ #:with-requirements
+ #:silent-seqprops
+ #:unapply
+ #:on-change
- ;; host.lisp
- #:host
- #:defhost
- #:make-host
- #:make-child-host
- #:hostattrs
- #:preprocess-host
- #:with-preserve-hostattrs
+ ;; host.lisp
+ #:host
+ #:defhost
+ #:make-host
+ #:make-child-host
+ #:hostattrs
+ #:preprocess-host
+ #:with-preserve-hostattrs
- ;; deployment.lisp
- #:defdeploy
- #:defdeploy-these
- #:deploy
- #:deploy*
- #:deploys
- #:deploys.
- #:deploy-these
- #:deploys-these.
- #:deploy-these*
- #:deploys-these
- #:continue-deploy*
+ ;; deployment.lisp
+ #:defdeploy
+ #:defdeploy-these
+ #:deploy
+ #:deploy*
+ #:deploys
+ #:deploys.
+ #:deploy-these
+ #:deploys-these.
+ #:deploy-these*
+ #:deploys-these
+ #:continue-deploy*
- ;; data.lisp
- #:data
- #:iden1
- #:iden2
- #:data-version
- #:data-mime
- #:string-data
- #:data-string
- #:file-data
- #:data-file
- #:missing-data-source
+ ;; data.lisp
+ #:data
+ #:iden1
+ #:iden2
+ #:data-version
+ #:data-mime
+ #:string-data
+ #:data-string
+ #:file-data
+ #:data-file
+ #:missing-data-source
- #:try-register-data-source
- #:register-data-source
- #:reset-data-sources
- #:skip-data-source
- #:get-data-stream
- #:with-data-stream
- #:get-data-string
- #:upload-all-prerequisite-data
- #:request-lisp-systems
- #:passphrase
- #:make-passphrase
- #:get-data-protected-string
- #:continue-deploy*-program))
+ #:try-register-data-source
+ #:register-data-source
+ #:reset-data-sources
+ #:skip-data-source
+ #:get-data-stream
+ #:with-data-stream
+ #:get-data-string
+ #:upload-all-prerequisite-data
+ #:request-lisp-systems
+ #:passphrase
+ #:make-passphrase
+ #:get-data-protected-string
+ #:continue-deploy*-program))
(defpackage :consfigurator.connection.shell-wrap
(:use #:cl #:consfigurator)
@@ -185,15 +185,15 @@
(defpackage :consfigurator.connection.ssh
(:use #:cl
- #:consfigurator
- #:alexandria
- #:consfigurator.connection.shell-wrap))
+ #:consfigurator
+ #:alexandria
+ #:consfigurator.connection.shell-wrap))
(defpackage :consfigurator.connection.sudo
(:use #:cl
- #:consfigurator
- #:alexandria
- #:consfigurator.connection.shell-wrap))
+ #:consfigurator
+ #:alexandria
+ #:consfigurator.connection.shell-wrap))
(defpackage :consfigurator.connection.local
(:use #:cl #:consfigurator #:alexandria)
@@ -207,8 +207,8 @@
(defpackage :consfigurator.connection.chroot.shell
(:use #:cl
- #:consfigurator
- #:consfigurator.connection.shell-wrap))
+ #:consfigurator
+ #:consfigurator.connection.shell-wrap))
(defpackage :consfigurator.property.cmd
(:use #:cl #:consfigurator)
@@ -218,62 +218,62 @@
(:use #:cl #:consfigurator #:alexandria)
(:local-nicknames (#:re #:cl-ppcre))
(:export #:has-content
- #:contains-lines
- #:has-mode
- #:does-not-exist
- #:data-uploaded
- #:host-data-uploaded
- #:secret-uploaded
- #:host-secret-uploaded
- #:regex-replaced-lines
- #:directory-exists))
+ #:contains-lines
+ #:has-mode
+ #:does-not-exist
+ #:data-uploaded
+ #:host-data-uploaded
+ #:secret-uploaded
+ #:host-secret-uploaded
+ #:regex-replaced-lines
+ #:directory-exists))
(defpackage :consfigurator.property.os
(:use #:cl #:consfigurator)
(:shadow #:typecase)
(:export #:unixlike
- #:linux
- #:linux-architecture
- #:debianlike
- #:debian
- #:debian-stable
- #:debian-testing
- #:debian-unstable
- #:debian-suite
- #:debian-architecture
- #:typecase
- #:host-typecase
- #:required
- #:supports-arch-p))
+ #:linux
+ #:linux-architecture
+ #:debianlike
+ #:debian
+ #:debian-stable
+ #:debian-testing
+ #:debian-unstable
+ #:debian-suite
+ #:debian-architecture
+ #:typecase
+ #:host-typecase
+ #:required
+ #:supports-arch-p))
(defpackage :consfigurator.property.service
(:use #:cl #:alexandria #:consfigurator)
(:local-nicknames (#:os #:consfigurator.property.os)
- (#:file #:consfigurator.property.file))
+ (#:file #:consfigurator.property.file))
(:export #:no-services
- #:running
- #:without-starting-services))
+ #:running
+ #:without-starting-services))
(defpackage :consfigurator.property.apt
(:use #:cl #:alexandria #:consfigurator)
(:local-nicknames (#:re #:cl-ppcre)
- (#:file #:consfigurator.property.file)
- (#:os #:consfigurator.property.os)
- (#:service #:consfigurator.property.service))
+ (#:file #:consfigurator.property.file)
+ (#:os #:consfigurator.property.os)
+ (#:service #:consfigurator.property.service))
(:export #:installed
- #:removed
- #:service-installed-running
- #:mirror
- #:uses-parent-mirror
- #:proxy
- #:uses-parent-proxy
- #:uses-local-cacher
- #:standard-sources.list))
+ #:removed
+ #:service-installed-running
+ #:mirror
+ #:uses-parent-mirror
+ #:proxy
+ #:uses-parent-proxy
+ #:uses-local-cacher
+ #:standard-sources.list))
(defpackage :consfigurator.connection.sbcl
(:use #:cl #:consfigurator)
(:local-nicknames (#:os #:consfigurator.property.os)
- (#:apt #:consfigurator.property.apt)))
+ (#:apt #:consfigurator.property.apt)))
(defpackage :consfigurator.property.user
(:use #:cl #:consfigurator)
@@ -283,11 +283,11 @@
(defpackage :consfigurator.property.chroot
(:use #:cl #:consfigurator #:alexandria)
(:local-nicknames (#:service #:consfigurator.property.service)
- (#:apt #:consfigurator.property.apt)
- (#:os #:consfigurator.property.os)
- (#:file #:consfigurator.property.file))
+ (#:apt #:consfigurator.property.apt)
+ (#:os #:consfigurator.property.os)
+ (#:file #:consfigurator.property.file))
(:export #:os-bootstrapped
- #:os-bootstrapped.))
+ #:os-bootstrapped.))
(defpackage :consfigurator.data.asdf
(:use #:cl #:consfigurator))
diff --git a/src/property.lisp b/src/property.lisp
index ba8c227..4107bce 100644
--- a/src/property.lisp
+++ b/src/property.lisp
@@ -94,8 +94,8 @@
(with-some-errors-are-failed-change
(let ((check (get prop 'check)))
(if (and check (apply check args))
- :no-change
- (apply (get prop 'papply (constantly :no-change)) args)))))
+ :no-change
+ (apply (get prop 'papply (constantly :no-change)) args)))))
(defun propappapply (propapp)
(apply #'propapply propapp))
@@ -104,8 +104,8 @@
(with-some-errors-are-failed-change
(let ((check (get prop 'check)))
(if (and check (not (apply check args)))
- :no-change
- (apply (get prop 'unapply (constantly :no-change)) args)))))
+ :no-change
+ (apply (get prop 'unapply (constantly :no-change)) args)))))
(defun propappunapply (propapp)
(apply #'propappunapply propapp))
@@ -124,53 +124,53 @@ see MAP-PROPSPEC-PROPAPPS for how they are used.")
(setf (get psym 'isprop) t)
(push psym *known-properties*)
(push `(,psym (&rest args)
- (let ((gensym (gensym)))
- (push (list* gensym ',psym args)
- *replaced-propapps*)
- gensym))
- *known-property-macrolets*)))
+ (let ((gensym (gensym)))
+ (push (list* gensym ',psym args)
+ *replaced-propapps*)
+ gensym))
+ *known-property-macrolets*)))
(defun dump-properties-for-emacs (from to)
(let ((put-forms
- (stripln
- (with-output-to-string (s)
- (loop
- for (prop . indent)
- in (nreverse (mappend (lambda (s) (get s 'indent))
- *known-properties*))
- do (format s " (put '~A 'common-lisp-indent-function '~A)~%"
- prop indent))))))
+ (stripln
+ (with-output-to-string (s)
+ (loop
+ for (prop . indent)
+ in (nreverse (mappend (lambda (s) (get s 'indent))
+ *known-properties*))
+ do (format s " (put '~A 'common-lisp-indent-function '~A)~%"
+ prop indent))))))
(with-open-file (in from)
(with-open-file (out to :direction :output :if-exists :supersede)
- (loop for line = (read-line in nil)
- while line
- do (princ (re:regex-replace " @putforms@" line put-forms) out)
- (terpri out))))))
+ (loop for line = (read-line in nil)
+ while line
+ do (princ (re:regex-replace " @putforms@" line put-forms) out)
+ (terpri out))))))
(defun store-indentation-info-for-emacs (sym args &optional info)
(let* ((package-short-name
- (lastcar (split-string (package-name *package*) :separator ".")))
- (short-name
- (string-downcase
- (if (string= package-short-name "CONSFIGURATOR")
- (symbol-name sym)
- (strcat package-short-name ":" (symbol-name sym)))))
- (dotted-name (strcat short-name "."))
- indent)
+ (lastcar (split-string (package-name *package*) :separator ".")))
+ (short-name
+ (string-downcase
+ (if (string= package-short-name "CONSFIGURATOR")
+ (symbol-name sym)
+ (strcat package-short-name ":" (symbol-name sym)))))
+ (dotted-name (strcat short-name "."))
+ indent)
(cond
(info
(push (cons short-name info) indent)
(push (cons dotted-name info) indent))
((not (find '&key args))
(let ((n (1- (loop with n = 0
- for arg in args
- if (member arg '(&rest &body &aux))
- return (1+ n)
- unless (eq arg '&optional)
- do (incf n)
- finally (return n)))))
- (when (plusp n)
- (push (cons dotted-name n) indent)))))
+ for arg in args
+ if (member arg '(&rest &body &aux))
+ return (1+ n)
+ unless (eq arg '&optional)
+ do (incf n)
+ finally (return n)))))
+ (when (plusp n)
+ (push (cons dotted-name n) indent)))))
(when indent
(setf (get sym 'indent) indent))))
@@ -186,37 +186,37 @@ dotted name alongside NAME."
(multiple-value-bind (required optional rest kwargs)
(parse-ordinary-lambda-list args :allow-specializers nil)
(let* ((will-props (not (or rest kwargs)))
- (main (nconc required optional))
- (firstsym (ensure-car (car main)))
- (first (and firstsym
- `(if (and (listp ,firstsym)
- (or (keywordp (car ,firstsym))
- (and (listp (car ,firstsym))
- (keywordp (caar ,firstsym)))))
- `',,firstsym
- ,firstsym)))
- (middle (mapcar #'ensure-car (butlast (if first (cdr main) main))))
- (new-args
- (if will-props
- (setq rest (ensure-car (lastcar main))
- main (nconc (nbutlast main) (list '&rest rest)))
- (nconc (list '&whole whole) (ordinary-ll-without-&aux args)))))
+ (main (nconc required optional))
+ (firstsym (ensure-car (car main)))
+ (first (and firstsym
+ `(if (and (listp ,firstsym)
+ (or (keywordp (car ,firstsym))
+ (and (listp (car ,firstsym))
+ (keywordp (caar ,firstsym)))))
+ `',,firstsym
+ ,firstsym)))
+ (middle (mapcar #'ensure-car (butlast (if first (cdr main) main))))
+ (new-args
+ (if will-props
+ (setq rest (ensure-car (lastcar main))
+ main (nconc (nbutlast main) (list '&rest rest)))
+ (nconc (list '&whole whole) (ordinary-ll-without-&aux args)))))
`(defmacro ,(format-symbol (symbol-package name) "~A." name) ,new-args
- ,@(cond
- ((and first will-props)
- `(`(,',name ,,first ,,@middle (make-propspec
- :propspec (props eseqprops ,@,rest)))))
- (will-props
- `(`(,',name ,,@middle (make-propspec
- :propspec (props eseqprops ,@,rest)))))
- (first
- `((declare (ignore ,@(cdr (ordinary-ll-variable-names
- (ordinary-ll-without-&aux args)))))
- (list* ',name ,first (cddr ,whole))))
- (t
- `((declare (ignore ,@(ordinary-ll-variable-names
- (ordinary-ll-without-&aux args))))
- (cons ',name (cdr ,whole)))))))))
+ ,@(cond
+ ((and first will-props)
+ `(`(,',name ,,first ,,@middle (make-propspec
+ :propspec (props eseqprops ,@,rest)))))
+ (will-props
+ `(`(,',name ,,@middle (make-propspec
+ :propspec (props eseqprops ,@,rest)))))
+ (first
+ `((declare (ignore ,@(cdr (ordinary-ll-variable-names
+ (ordinary-ll-without-&aux args)))))
+ (list* ',name ,first (cddr ,whole))))
+ (t
+ `((declare (ignore ,@(ordinary-ll-variable-names
+ (ordinary-ll-without-&aux args))))
+ (cons ',name (cdr ,whole)))))))))
(defmacro define-property-defining-macro
(mname (typev lambdav slotsv formsv) &body mbody)
@@ -227,47 +227,47 @@ parsing FORMSV and pushing SETPROP keyword argument pairs to plist SLOTSV."
(declare (ignore mdeclarations))
(with-gensyms (name body declarations)
`(defmacro ,mname (,name ,typev ,lambdav &body ,body)
- ,@(and mdocstring `(,mdocstring))
- (let ((,slotsv (list :type ,typev :lambda `',,lambdav)))
- (multiple-value-bind (,formsv ,declarations)
- (parse-body ,body :documentation t)
- (when (> (length ,declarations) 1)
- (error "Multiple DECLARE forms unsupported."))
- ,@mforms
- (let ((indent (cadr (assoc 'indent (cdar ,declarations)))))
- `(progn
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (record-known-property ',,name))
- (store-indentation-info-for-emacs ',,name ',,lambdav ,indent)
- (setprop ',,name ,@,slotsv)
- (define-dotted-property-macro ,,name ,,lambdav)
- ;; Now prepare a DEFUN for the property, to enable calling
- ;; it programmatically within the :APPLY and :UNAPPLY
- ;; routines of other properties. This can lead to clearer
- ;; code than going via DEFPROPSPEC/DEFPROPLIST for simple
- ;; things like installing packages.
- ,@(and
- (getf ,slotsv :apply)
- `((defun-with-args ,,name args ,,lambdav
- ;; Properties with :HOSTATTRS subroutines which set
- ;; new hostattrs should not be used programmatically
- ;; in this way, so issue a warning.
- ,@(and (getf ,slotsv :hostattrs)
- '((programmatic-apply-hostattrs)))
- (%consfigure
- nil
- (make-host
- :propspec
- (make-propspec
- :systems nil
- :propspec (cons ',,name args)))))))))))))))
+ ,@(and mdocstring `(,mdocstring))
+ (let ((,slotsv (list :type ,typev :lambda `',,lambdav)))
+ (multiple-value-bind (,formsv ,declarations)
+ (parse-body ,body :documentation t)
+ (when (> (length ,declarations) 1)
+ (error "Multiple DECLARE forms unsupported."))
+ ,@mforms
+ (let ((indent (cadr (assoc 'indent (cdar ,declarations)))))
+ `(progn
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (record-known-property ',,name))
+ (store-indentation-info-for-emacs ',,name ',,lambdav ,indent)
+ (setprop ',,name ,@,slotsv)
+ (define-dotted-property-macro ,,name ,,lambdav)
+ ;; Now prepare a DEFUN for the property, to enable calling
+ ;; it programmatically within the :APPLY and :UNAPPLY
+ ;; routines of other properties. This can lead to clearer
+ ;; code than going via DEFPROPSPEC/DEFPROPLIST for simple
+ ;; things like installing packages.
+ ,@(and
+ (getf ,slotsv :apply)
+ `((defun-with-args ,,name args ,,lambdav
+ ;; Properties with :HOSTATTRS subroutines which set
+ ;; new hostattrs should not be used programmatically
+ ;; in this way, so issue a warning.
+ ,@(and (getf ,slotsv :hostattrs)
+ '((programmatic-apply-hostattrs)))
+ (%consfigure
+ nil
+ (make-host
+ :propspec
+ (make-propspec
+ :systems nil
+ :propspec (cons ',,name args)))))))))))))))
(define-condition programmatic-apply-hostattrs (simple-warning) ())
(defun programmatic-apply-hostattrs ()
(warn 'programmatic-apply-hostattrs
- :format-control
- "Calling property which has :HOSTATTRS subroutine programmatically.
+ :format-control
+ "Calling property which has :HOSTATTRS subroutine programmatically.
Use DEFPROPLIST/DEFPROPSPEC to avoid trouble."))
(defmacro ignoring-hostattrs (form)
@@ -278,8 +278,8 @@ subroutine does not push any new hostattrs."
(unless (and (listp form) (isprop (car form)))
(simple-program-error "~A is not a programmatic call to a property." form))
`(handler-bind ((programmatic-apply-hostattrs
- (lambda (w)
- (invoke-restart (find-restart 'muffle-warning w)))))
+ (lambda (w)
+ (invoke-restart (find-restart 'muffle-warning w)))))
,form))
;; supported ways to write properties are DEFPROP, DEFPROPSPEC and DEFPROPLIST
@@ -287,12 +287,12 @@ subroutine does not push any new hostattrs."
(define-property-defining-macro defprop (type lambda slots forms)
"Define a property by providing code for its subroutines."
(loop for form in forms
- if (keywordp (car form))
- do (setf (getf slots (car form)) (cdr form)))
+ if (keywordp (car form))
+ do (setf (getf slots (car form)) (cdr form)))
(loop for kw in '(:desc :preprocess :hostattrs :check :apply :unapply)
- do (if-let ((slot (getf slots kw)))
- (setf (getf slots kw)
- `(lambda ,lambda ,@slot)))))
+ do (if-let ((slot (getf slots kw)))
+ (setf (getf slots kw)
+ `(lambda ,lambda ,@slot)))))
(define-property-defining-macro defpropspec (type lambda slots forms)
"Define a property which constructs, evaluates and applies a propspec.
@@ -324,30 +324,30 @@ You can usually use DEFPROPLIST instead of DEFPROPSPEC, which see."
;; and :UNAPPLY subroutines can get at it. We have to keep the original
;; arguments to the propapp around for the sake of the :DESC subroutine.
(setf (getf slots :preprocess)
- '(lambda (&rest args)
- (list (list :propspec nil :orig-args args))))
+ '(lambda (&rest args)
+ (list (list :propspec nil :orig-args args))))
(setf (getf slots :apply)
- '(lambda (plist)
- (propappapply (eval-propspec (getf plist :propspec)))))
+ '(lambda (plist)
+ (propappapply (eval-propspec (getf plist :propspec)))))
(setf (getf slots :unapply)
- '(lambda (plist)
- (propappunapply (eval-propspec (getf plist :propspec)))))
+ '(lambda (plist)
+ (propappunapply (eval-propspec (getf plist :propspec)))))
(when (form-beginning-with :desc (car forms))
(setf (getf slots :desc)
- `(lambda (plist)
- (destructuring-bind ,(ordinary-ll-without-&aux lambda)
- (getf plist :orig-args)
- ,@(cdr (pop forms))))))
+ `(lambda (plist)
+ (destructuring-bind ,(ordinary-ll-without-&aux lambda)
+ (getf plist :orig-args)
+ ,@(cdr (pop forms))))))
(setf (getf slots :hostattrs)
- `(lambda (plist)
- (let ((propspec (preprocess-propspec
- (make-propspec
- :systems (propspec-systems (host-propspec *host*))
- :propspec (destructuring-bind ,lambda
- (getf plist :orig-args)
- ,@forms)))))
- (setf (getf plist :propspec) propspec)
- (propappattrs (eval-propspec propspec))))))
+ `(lambda (plist)
+ (let ((propspec (preprocess-propspec
+ (make-propspec
+ :systems (propspec-systems (host-propspec *host*))
+ :propspec (destructuring-bind ,lambda
+ (getf plist :orig-args)
+ ,@forms)))))
+ (setf (getf plist :propspec) propspec)
+ (propappattrs (eval-propspec propspec))))))
(defmacro defproplist (name type lambda &body properties)
"Like DEFPROPSPEC, but define the function which yields the propspec using the
@@ -374,14 +374,14 @@ sometimes you will need to fall back on DEFPROPSPEC. For example, an
unevaluated property application specification cannot express passing values
other than constant values and propapps to property combinators."
(let ((propspec
- (loop for remaining on properties
- for car = (car remaining)
- if (or (stringp car)
- (and (listp car) (member (car car) '(:desc declare))))
- collect car into begin
- else
- return (nreverse
- (cons `(props eseqprops ,@remaining) begin)))))
+ (loop for remaining on properties
+ for car = (car remaining)
+ if (or (stringp car)
+ (and (listp car) (member (car car) '(:desc declare))))
+ collect car into begin
+ else
+ return (nreverse
+ (cons `(props eseqprops ,@remaining) begin)))))
`(defpropspec ,name ,type ,lambda ,@propspec)))
diff --git a/src/property/apt.lisp b/src/property/apt.lisp
index 774af75..2b3ecba 100644
--- a/src/property/apt.lisp
+++ b/src/property/apt.lisp
@@ -78,7 +78,7 @@ E.g. (APT:SERVICE-INSTALLED-RUNNING \"apache2\")."
(pushnew-hostattrs :apt.proxy uri))
(:apply
(file:has-content "/etc/apt/apt.conf.d/20proxy"
- (format nil "Acquire::HTTP::Proxy \"~A\";~%" uri))))
+ (format nil "Acquire::HTTP::Proxy \"~A\";~%" uri))))
(defproplist uses-parent-proxy :posix ()
(:desc #?"Uses parent's apt proxy")
@@ -103,17 +103,17 @@ E.g. (APT:SERVICE-INSTALLED-RUNNING \"apache2\")."
(defmethod standard-sources-for ((os os:debian))
(let* ((suite (os:debian-suite os))
- (archive (mapcar (lambda (m) (list* m suite +sections+))
- (get-mirrors)))
- (security-suite (if (memstring= suite '("stretch" "jessie" "buster"))
- #?"${suite}/updates"
- #?"${suite}-security"))
- (security (and (not (subtypep (type-of os) 'os:debian-unstable))
- (list
- (list* "http://security.debian.org/debian-security"
- security-suite +sections+)))))
+ (archive (mapcar (lambda (m) (list* m suite +sections+))
+ (get-mirrors)))
+ (security-suite (if (memstring= suite '("stretch" "jessie" "buster"))
+ #?"${suite}/updates"
+ #?"${suite}-security"))
+ (security (and (not (subtypep (type-of os) 'os:debian-unstable))
+ (list
+ (list* "http://security.debian.org/debian-security"
+ security-suite +sections+)))))
(mapcan (lambda (l) (list #?"deb @{l}" #?"deb-src @{l}"))
- (nconc archive security))))
+ (nconc archive security))))
;;;; Reports on installation status
@@ -126,20 +126,20 @@ E.g. (APT:SERVICE-INSTALLED-RUNNING \"apache2\")."
(defun all-installed-p (packages)
(loop with n = 0
- for line in (apt-cache-policy packages)
- when (re:scan apt-cache-policy-installed line)
- do (incf n)
- finally (return (= n (length packages)))))
+ for line in (apt-cache-policy packages)
+ when (re:scan apt-cache-policy-installed line)
+ do (incf n)
+ finally (return (= n (length packages)))))
(defun none-installed-p (packages)
(loop for line in (apt-cache-policy packages)
- never (re:scan apt-cache-policy-installed line)))
+ never (re:scan apt-cache-policy-installed line)))
;;;; Utilities
(defun apt-get (&rest args)
(apply #'run
- :env '(:DEBIAN_FRONTEND "noninteractive"
- :APT_LISTCHANGES_FRONTEND "none")
- "apt-get" args))
+ :env '(:DEBIAN_FRONTEND "noninteractive"
+ :APT_LISTCHANGES_FRONTEND "none")
+ "apt-get" args))
diff --git a/src/property/chroot.lisp b/src/property/chroot.lisp
index 220d5f9..79126bd 100644
--- a/src/property/chroot.lisp
+++ b/src/property/chroot.lisp
@@ -24,18 +24,18 @@
(declare (ignore options host))
;; check whether a previous debootstrap failed partway through
(if (test "-d" (merge-pathnames "debootstrap/"
- (ensure-directory-pathname root)))
+ (ensure-directory-pathname root)))
(progn (mrun "rm" "-rf" root) nil)
(test "-d" root)))
(:apply
(let* ((os (car (getf (hostattrs host) :os)))
- (args (list (if (os:supports-arch-p (get-hostattrs-car :os)
- (os:linux-architecture os))
- "debootstrap" "qemu-debootstrap")
- (plist-to-cmd-args options)
- (strcat "--arch=" (os:debian-architecture os))
- (os:debian-suite os)
- root)))
+ (args (list (if (os:supports-arch-p (get-hostattrs-car :os)
+ (os:linux-architecture os))
+ "debootstrap" "qemu-debootstrap")
+ (plist-to-cmd-args options)
+ (strcat "--arch=" (os:debian-architecture os))
+ (os:debian-suite os)
+ root)))
(when-let ((proxy (get-hostattrs-car :apt.proxy)))
(setq args (list* :env (list :http_proxy proxy) args)))
(when-let ((mirror (get-hostattrs-car :apt.mirror)))
@@ -47,7 +47,7 @@
`(os:host-typecase ,host
(debian
(os:typecase
- (debianlike (apt:installed "debootstrap"))))))
+ (debianlike (apt:installed "debootstrap"))))))
(defpropspec %os-bootstrapped :posix (options root host)
"Bootstrap OS into ROOT, e.g. with debootstrap(1)."
@@ -60,18 +60,18 @@
(defproplist os-bootstrapped :lisp
(options root properties
- &aux (host
- (preprocess-host
- (make-child-host
- :propspec
- (make-propspec
- :systems (propspec-systems properties)
- :propspec `(service:without-starting-services
- ,(propspec-props properties)))))))
+ &aux (host
+ (preprocess-host
+ (make-child-host
+ :propspec
+ (make-propspec
+ :systems (propspec-systems properties)
+ :propspec `(service:without-starting-services
+ ,(propspec-props properties)))))))
"Bootstrap an OS into ROOT and apply PROPERTIES.
OPTIONS is a plist of values to pass to the OS-specific bootstrapping property."
(:desc (declare (ignore options properties))
- #?"Built chroot @ ${root}")
+ #?"Built chroot @ ${root}")
(%os-bootstrapper-installed host)
(%os-bootstrapped options root host)
(deploys `((:chroot :into ,root)) host))
diff --git a/src/property/file.lisp b/src/property/file.lisp
index 241e32e..5d2f532 100644
--- a/src/property/file.lisp
+++ b/src/property/file.lisp
@@ -24,24 +24,24 @@
For efficiency, a :LISP property might want to use streams, but there's no
point in doing that here because WRITEFILE is synchronous."
(let* ((orig-lines (lines (readfile file)))
- (new-lines (funcall function orig-lines)))
+ (new-lines (funcall function orig-lines)))
(if (equal orig-lines new-lines)
- :no-change
- (writefile file (unlines new-lines)))))
+ :no-change
+ (writefile file (unlines new-lines)))))
(defprop has-content :posix (path content)
"Ensure there is a file at PATH whose content is CONTENT.
CONTENT can be a list of lines or a single string."
(declare (indent 1))
(:apply (writefile path (etypecase content
- (cons (unlines content))
- (string (format nil "~A~&" content))))))
+ (cons (unlines content))
+ (string (format nil "~A~&" content))))))
(defprop contains-lines :posix (path lines)
"Ensure there is a file at PATH containing each of LINES once."
(:apply
(let ((new-lines (copy-list lines))
- (existing-lines (lines (readfile path))))
+ (existing-lines (lines (readfile path))))
(dolist (existing-line existing-lines)
(deletef new-lines existing-line :test #'string=))
(writefile path (unlines (nconc existing-lines new-lines))))))
@@ -55,8 +55,8 @@ CONTENT can be a list of lines or a single string."
(defprop does-not-exist :posix (&rest paths)
"Ensure that files do not exist."
(:desc (if (cdr paths)
- #?"@{paths} do not exist"
- #?"${(car paths)} does not exist"))
+ #?"@{paths} do not exist"
+ #?"${(car paths)} does not exist"))
(:apply (mrun "rm" "-f" paths)))
(defprop data-uploaded :posix (iden1 iden2 destination)
diff --git a/src/property/os.lisp b/src/property/os.lisp
index ebda05e..f89534e 100644
--- a/src/property/os.lisp
+++ b/src/property/os.lisp
@@ -32,13 +32,13 @@
(defclass debian (debianlike)
((suite :initarg :suite
- :reader debian-suite
- :initform (error "Must provide suite"))))
+ :reader debian-suite
+ :initform (error "Must provide suite"))))
(defmethod print-object ((os debian) stream)
(format stream "#.~S" `(make-instance 'debian
- :arch ,(linux-architecture os)
- :suite ,(debian-suite os)))
+ :arch ,(linux-architecture os)
+ :suite ,(debian-suite os)))
os)
(defclass debian-stable (debian) ())
@@ -49,8 +49,8 @@
#?{Host is Debian "${suite}"})
(:hostattrs
(push-hostattrs :os
- (make-instance 'debian-stable
- :arch architecture :suite suite))))
+ (make-instance 'debian-stable
+ :arch architecture :suite suite))))
(defclass debian-testing (debian)
((suite :initform "testing")))
@@ -61,8 +61,8 @@
"Host is Debian testing")
(:hostattrs
(push-hostattrs :os
- (make-instance 'debian-testing
- :arch architecture))))
+ (make-instance 'debian-testing
+ :arch architecture))))
(defclass debian-unstable (debian)
((suite :initform "unstable")))
@@ -73,8 +73,8 @@
"Host is Debian unstable")
(:hostattrs
(push-hostattrs :os
- (make-instance 'debian-unstable
- :arch architecture))))
+ (make-instance 'debian-unstable
+ :arch architecture))))
(defmethod debian-architecture ((os linux))
"Return a string representing the architecture of OS as used by Debian."
@@ -85,28 +85,28 @@
(define-function-property-combinator os-typecase* (host &rest cases)
(flet ((choose-propapp ()
- (or (loop with os = (class-of (if host
- (car (getf (hostattrs host) :os))
- (get-hostattrs-car :os)))
- for (type propapp) on cases by #'cddr
- when (subtypep os type) return propapp)
- (inapplicable-property
- "Host's OS ~S fell through OS:TYPECASE."
- (class-of (get-hostattrs-car :os))))))
+ (or (loop with os = (class-of (if host
+ (car (getf (hostattrs host) :os))
+ (get-hostattrs-car :os)))
+ for (type propapp) on cases by #'cddr
+ when (subtypep os type) return propapp)
+ (inapplicable-property
+ "Host's OS ~S fell through OS:TYPECASE."
+ (class-of (get-hostattrs-car :os))))))
(:retprop :type (collapse-types (loop for propapp in (cdr cases) by #'cddr
- collect (propapptype propapp)))
- :desc (lambda (&rest args)
- (declare (ignore args))
- (propappdesc (choose-propapp)))
- :hostattrs (lambda (&rest args)
- (declare (ignore args))
- (propappattrs (choose-propapp)))
- :apply (lambda (&rest args)
- (declare (ignore args))
- (propappapply (choose-propapp)))
- :unapply (lambda (&rest args)
- (declare (ignore args))
- (propappunapply (choose-propapp))))))
+ collect (propapptype propapp)))
+ :desc (lambda (&rest args)
+ (declare (ignore args))
+ (propappdesc (choose-propapp)))
+ :hostattrs (lambda (&rest args)
+ (declare (ignore args))
+ (propappattrs (choose-propapp)))
+ :apply (lambda (&rest args)
+ (declare (ignore args))
+ (propappapply (choose-propapp)))
+ :unapply (lambda (&rest args)
+ (declare (ignore args))
+ (propappunapply (choose-propapp))))))
(defmacro typecase (&body cases)
`(host-typecase nil ,@cases))
@@ -115,9 +115,9 @@
`(os-typecase*
,host
,@(loop for case in cases
- collect `',(intern (symbol-name (car case))
- (find-package :consfigurator.property.os))
- collect (cadr case))))
+ collect `',(intern (symbol-name (car case))
+ (find-package :consfigurator.property.os))
+ collect (cadr case))))
;;;; Utilities
@@ -134,6 +134,6 @@ Used in property :HOSTATTRS subroutines."
"Can binaries of type ARCH run on OS?"
(cl:typecase os
(debian (or (eq (linux-architecture os) arch)
- (member arch (assoc (linux-architecture os)
- '((:amd64 :i386)
- (:i386 :amd64))))))))
+ (member arch (assoc (linux-architecture os)
+ '((:amd64 :i386)
+ (:i386 :amd64))))))))
diff --git a/src/property/service.lisp b/src/property/service.lisp
index badf5b9..1d7a334 100644
--- a/src/property/service.lisp
+++ b/src/property/service.lisp
@@ -62,29 +62,29 @@ properties."
"Apply PROPAPPS with SERVICE:NO-SERVICES temporarily in effect."
(let ((propapp (if (cdr propapps) (eseqprops propapps) (car propapps))))
(:retprop :type :lisp
- :hostattrs
- (lambda () (propappattrs propapp) (os:required 'os:debianlike))
- :apply
- (lambda (&aux (already-exists (file-exists-p +policyrcd+)))
- (with-remote-temporary-file (temp :directory "/usr/sbin")
- (when already-exists
- (rename-file +policyrcd+ temp))
- (%policy-rc.d)
- (let ((before (get-universal-time)))
- ;; Sleep for one second so that we know BEFORE is in the
- ;; past. (SLEEP 1) is only approximately one second so
- ;; check that it's actually been a second.
- (loop do (sleep 1) until (> (get-universal-time) before))
- (unwind-protect
- (with-preserve-hostattrs
- (push-hostattrs :no-services t)
- (propappapply propapp))
- (if already-exists
- ;; Check whether some property we applied set the
- ;; contents of /usr/sbin/policy-rc.d, in which case
- ;; we won't restore our backup.
- (unless (> (file-write-date +policyrcd+) before)
- (rename-file temp +policyrcd+))
- (when (file-exists-p +policyrcd+)
- (delete-file +policyrcd+)))))))
- :unapply (lambda () (propappunapply propapp)))))
+ :hostattrs
+ (lambda () (propappattrs propapp) (os:required 'os:debianlike))
+ :apply
+ (lambda (&aux (already-exists (file-exists-p +policyrcd+)))
+ (with-remote-temporary-file (temp :directory "/usr/sbin")
+ (when already-exists
+ (rename-file +policyrcd+ temp))
+ (%policy-rc.d)
+ (let ((before (get-universal-time)))
+ ;; Sleep for one second so that we know BEFORE is in the
+ ;; past. (SLEEP 1) is only approximately one second so
+ ;; check that it's actually been a second.
+ (loop do (sleep 1) until (> (get-universal-time) before))
+ (unwind-protect
+ (with-preserve-hostattrs
+ (push-hostattrs :no-services t)
+ (propappapply propapp))
+ (if already-exists
+ ;; Check whether some property we applied set the
+ ;; contents of /usr/sbin/policy-rc.d, in which case
+ ;; we won't restore our backup.
+ (unless (> (file-write-date +policyrcd+) before)
+ (rename-file temp +policyrcd+))
+ (when (file-exists-p +policyrcd+)
+ (delete-file +policyrcd+)))))))
+ :unapply (lambda () (propappunapply propapp)))))
diff --git a/src/propspec.lisp b/src/propspec.lisp
index bde3826..2e401f6 100644
--- a/src/propspec.lisp
+++ b/src/propspec.lisp
@@ -68,30 +68,30 @@ arguments to properties in propapps, but that should not be needed."
;; trivial-macroexpand-all library to get at these implementations).
(labels
((macrolet-and-expand (macrolets form)
- (multiple-value-bind (expanded supported env-supported)
- (trivial-macroexpand-all:macroexpand-all
- `(macrolet ,macrolets ,form) env)
- (unless supported
- (error "Don't know how to MACROEXPAND-ALL in this Lisp."))
- (when (and env (not env-supported))
- (error "Don't know how to MACROEXPAND-ALL with env in this Lisp."))
- ;; At least SB-CLTL2:MACROEXPAND-ALL leaves the MACROLET in, so use
- ;; CADDR to remove it again -- if that turns out to be
- ;; implementation-specific, we can look for what we added and
- ;; remove it.
- ;;
- ;; This is not just to avoid leaking our implementation to our
- ;; callers -- if we call this function more than once with old
- ;; calls to MACROLET left in, we can get stuck in infinite macro
- ;; expansion loops.
- (caddr expanded)))
+ (multiple-value-bind (expanded supported env-supported)
+ (trivial-macroexpand-all:macroexpand-all
+ `(macrolet ,macrolets ,form) env)
+ (unless supported
+ (error "Don't know how to MACROEXPAND-ALL in this Lisp."))
+ (when (and env (not env-supported))
+ (error "Don't know how to MACROEXPAND-ALL with env in this Lisp."))
+ ;; At least SB-CLTL2:MACROEXPAND-ALL leaves the MACROLET in, so use
+ ;; CADDR to remove it again -- if that turns out to be
+ ;; implementation-specific, we can look for what we added and
+ ;; remove it.
+ ;;
+ ;; This is not just to avoid leaking our implementation to our
+ ;; callers -- if we call this function more than once with old
+ ;; calls to MACROLET left in, we can get stuck in infinite macro
+ ;; expansion loops.
+ (caddr expanded)))
(walk (tree)
- (if (atom tree)
- (if-let ((propapp (gethash tree *replaced-propapps*)))
- (funcall function propapp)
- (if reconstruct `',tree tree))
- (let ((walked (mapcar #'walk tree)))
- (if reconstruct (cons 'list walked) walked)))))
+ (if (atom tree)
+ (if-let ((propapp (gethash tree *replaced-propapps*)))
+ (funcall function propapp)
+ (if reconstruct `',tree tree))
+ (let ((walked (mapcar #'walk tree)))
+ (if reconstruct (cons 'list walked) walked)))))
;; First we need to find all the propapps, after macro expansion.
;; Propapps contain the arguments to be passed to properties rather than
;; expressions which will evaluate to those arguments, and some of these
@@ -105,10 +105,10 @@ arguments to properties in propapps, but that should not be needed."
;; the same (as indeed it often will be) then we would get stuck in an
;; infinite macro expansion. So we substitute back and forth for gensyms.
(let ((expanded
- (handler-case
- (macrolet-and-expand *known-property-macrolets* propspec)
- (error ()
- (error 'invalid-or-ambiguous-propspec :propspec propspec)))))
+ (handler-case
+ (macrolet-and-expand *known-property-macrolets* propspec)
+ (error ()
+ (error 'invalid-or-ambiguous-propspec :propspec propspec)))))
;; Now we use a dummy macro expansion pass to find any symbols without
;; function or property definitions occurring in function call
;; positions. These could potentially be properties whose definitions
@@ -118,19 +118,19 @@ arguments to properties in propapps, but that should not be needed."
;; in the propspec. So error out if we detect that situation.
(macrolet-and-expand
(loop for leaf in (delete-duplicates (flatten expanded))
- if (and (symbolp leaf) (not (isprop leaf)))
- collect `(,leaf (&rest args)
- (unless (or (fboundp ',leaf) (isprop ',leaf))
- (error 'ambiguous-propspec :name ',leaf))
- ;; return something which looks like an
- ;; ordinary function call to the code walker,
- ;; so that it will recurse into ARGS
- (cons (gensym) args)))
+ if (and (symbolp leaf) (not (isprop leaf)))
+ collect `(,leaf (&rest args)
+ (unless (or (fboundp ',leaf) (isprop ',leaf))
+ (error 'ambiguous-propspec :name ',leaf))
+ ;; return something which looks like an
+ ;; ordinary function call to the code walker,
+ ;; so that it will recurse into ARGS
+ (cons (gensym) args)))
expanded)
;; Finally, substitute the mapped propapps back in to the propspec.
(let ((*replaced-propapps*
- (alist-hash-table *replaced-propapps* :test 'eq)))
- (walk expanded)))))
+ (alist-hash-table *replaced-propapps* :test 'eq)))
+ (walk expanded)))))
(defmacro in-consfig (systems)
"Sets the variable *CONSFIG* in the current package to SYSTEMS, or (SYSTEMS)
@@ -160,8 +160,8 @@ package applies to hosts."))))
((systems
:initarg :systems
:initform (or (symbol-value (find-symbol "*CONSFIG*"))
- (error
- "Looks like *CONSFIG* is not set; please call IN-CONSFIG"))
+ (error
+ "Looks like *CONSFIG* is not set; please call IN-CONSFIG"))
:reader propspec-systems
:documentation
"List of names of ASDF systems, the loading of all of which is sufficient
@@ -192,12 +192,12 @@ PRINT-OBJECT."))
(defmethod preprocess-propspec ((propspec unpreprocessed-propspec))
(make-instance 'preprocessed-propspec
- :systems (propspec-systems propspec)
- :propspec (map-propspec-propapps
- (lambda (propapp)
- (destructuring-bind (prop . args) propapp
- `',(cons prop (apply (proppp prop) args))))
- (propspec-props propspec))))
+ :systems (propspec-systems propspec)
+ :propspec (map-propspec-propapps
+ (lambda (propapp)
+ (destructuring-bind (prop . args) propapp
+ `',(cons prop (apply (proppp prop) args))))
+ (propspec-props propspec))))
(defun make-propspec (&key (systems nil systems-supplied-p) propspec)
"Convert a property application specification expression into a property
@@ -205,24 +205,24 @@ application specification proper by associating it with a list of ASDF
systems."
(if systems-supplied-p
(make-instance 'unpreprocessed-propspec
- :systems systems :propspec propspec)
+ :systems systems :propspec propspec)
(make-instance 'unpreprocessed-propspec :propspec propspec)))
(defmethod print-object ((propspec unpreprocessed-propspec) stream)
(format stream "#.~S" `(make-instance
- 'unpreprocessed-propspec
- :systems ',(slot-value propspec 'systems)
- :propspec
- ',(slot-value propspec 'propspec-expression)))
+ 'unpreprocessed-propspec
+ :systems ',(slot-value propspec 'systems)
+ :propspec
+ ',(slot-value propspec 'propspec-expression)))
propspec)
(defmethod print-object ((propspec preprocessed-propspec) stream)
(format stream "#.~S" `(make-instance
- 'preprocessed-propspec
- :systems ',(slot-value propspec 'systems)
- :propspec
- ',(slot-value propspec
- 'preprocessed-propspec-expression)))
+ 'preprocessed-propspec
+ :systems ',(slot-value propspec 'systems)
+ :propspec
+ ',(slot-value propspec
+ 'preprocessed-propspec-expression)))
propspec)
;; this could be defined for preprocessed propspecs easily enough but we
@@ -230,12 +230,12 @@ systems."
(defmethod append-propspecs
((first unpreprocessed-propspec) (second unpreprocessed-propspec))
(make-propspec :systems (union (propspec-systems first)
- (propspec-systems second))
- :propspec (let ((firstp (propspec-props first))
- (secondp (propspec-props second)))
- (if (and firstp secondp)
- `(silent-seqprops ,firstp ,secondp)
- (or firstp secondp)))))
+ (propspec-systems second))
+ :propspec (let ((firstp (propspec-props first))
+ (secondp (propspec-props second)))
+ (if (and firstp secondp)
+ `(silent-seqprops ,firstp ,secondp)
+ (or firstp secondp)))))
(defmethod eval-propspec ((propspec preprocessed-propspec))
(eval (slot-value propspec 'preprocessed-propspec-expression)))
@@ -257,10 +257,10 @@ processed."
application specification expression to a property application specification
expression."
(flet ((evaluate (propapp)
- `(list ',(car propapp) ,@(cdr propapp))))
+ `(list ',(car propapp) ,@(cdr propapp))))
(handler-case
- (map-propspec-propapps #'evaluate (cons combinator forms) t)
+ (map-propspec-propapps #'evaluate (cons combinator forms) t)
(ambiguous-propspec (c)
- ;; resignal with a more specific error message
- (error 'ambiguous-unevaluated-propspec
- :name (cell-error-name c))))))
+ ;; resignal with a more specific error message
+ (error 'ambiguous-unevaluated-propspec
+ :name (cell-error-name c))))))
diff --git a/src/util.lisp b/src/util.lisp
index 242fbdb..7ee7e1a 100644
--- a/src/util.lisp
+++ b/src/util.lisp
@@ -31,13 +31,13 @@
(defmacro symbol-named (name symbol)
`(and (symbolp ,symbol)
- (string= (symbol-name ',name) (symbol-name ,symbol))))
+ (string= (symbol-name ',name) (symbol-name ,symbol))))
(defun normalise-system (system)
(etypecase system
(string system)
(symbol (string-downcase
- (symbol-name system)))))
+ (symbol-name system)))))
(defun memstring= (string list)
(member string list :test #'string=))
@@ -51,8 +51,8 @@ which fail this assertion."
(or
(not
(member arg
- '#.(set-difference lambda-list-keywords
- '(&optional &rest &key &allow-other-keys &aux))))
+ '#.(set-difference lambda-list-keywords
+ '(&optional &rest &key &allow-other-keys &aux))))
(simple-program-error
"Implementation-specific or non-ordinary lambda list keyword ~A not
supported."
@@ -60,17 +60,17 @@ supported."
(defun ordinary-ll-without-&aux (ll)
(loop for arg in ll
- do (assert-ordinary-ll-member arg)
- if (eq '&aux arg) return accum
- else collect arg into accum
- finally (return accum)))
+ do (assert-ordinary-ll-member arg)
+ if (eq '&aux arg) return accum
+ else collect arg into accum
+ finally (return accum)))
(defun ordinary-ll-variable-names (ll)
(loop for arg in ll
- for arg* = (ensure-car arg)
- do (assert-ordinary-ll-member arg)
- unless (char= #\& (char (symbol-name arg*) 0))
- collect arg*))
+ for arg* = (ensure-car arg)
+ do (assert-ordinary-ll-member arg)
+ unless (char= #\& (char (symbol-name arg*) 0))
+ collect arg*))
(defmacro defun-with-args (name argsym lambda-list &body forms &aux remaining)
(multiple-value-bind (required optional rest kwargs aokeys)
@@ -80,32 +80,32 @@ supported."
"&ALLOW-OTHER-KEYS without &REST in property lambda list not supported."))
(let ((normalisedll (reverse required)))
(when optional
- (push '&optional normalisedll)
- (loop for (name init suppliedp) in optional
- for suppliedp* = (or suppliedp (gensym))
- do (push `(,name ,init ,suppliedp*) normalisedll)
- do (push `(when ,suppliedp* (push ,name ,argsym)) remaining)))
+ (push '&optional normalisedll)
+ (loop for (name init suppliedp) in optional
+ for suppliedp* = (or suppliedp (gensym))
+ do (push `(,name ,init ,suppliedp*) normalisedll)
+ do (push `(when ,suppliedp* (push ,name ,argsym)) remaining)))
(when rest
- (push '&rest normalisedll)
- (push rest normalisedll)
- (push `(dolist (r ,rest) (push r ,argsym)) remaining))
+ (push '&rest normalisedll)
+ (push rest normalisedll)
+ (push `(dolist (r ,rest) (push r ,argsym)) remaining))
(when kwargs
- (push '&key normalisedll)
- (loop for ((keyword-name name) init suppliedp) in kwargs
- for suppliedp* = (if (or rest suppliedp) suppliedp (gensym))
- do (push `((,keyword-name ,name) ,init ,suppliedp*)
- normalisedll)
- unless rest do (push `(when ,suppliedp*
- (push ,keyword-name ,argsym)
- (push ,name ,argsym))
- remaining)))
+ (push '&key normalisedll)
+ (loop for ((keyword-name name) init suppliedp) in kwargs
+ for suppliedp* = (if (or rest suppliedp) suppliedp (gensym))
+ do (push `((,keyword-name ,name) ,init ,suppliedp*)
+ normalisedll)
+ unless rest do (push `(when ,suppliedp*
+ (push ,keyword-name ,argsym)
+ (push ,name ,argsym))
+ remaining)))
(when aokeys
- (push '&allow-other-keys normalisedll))
+ (push '&allow-other-keys normalisedll))
`(defun ,name ,(nreverse normalisedll)
- (let ((,argsym (list ,@(reverse required))))
- ,@(nreverse remaining)
- (nreversef ,argsym)
- ,@forms)))))
+ (let ((,argsym (list ,@(reverse required))))
+ ,@(nreverse remaining)
+ (nreversef ,argsym)
+ ,@forms)))))
(defmacro define-simple-error (name &optional docstring)
`(progn
@@ -120,12 +120,12 @@ supported."
(defun strip-declarations (forms)
(loop while (form-beginning-with declare (car forms))
- do (pop forms)
- finally (return forms)))
+ do (pop forms)
+ finally (return forms)))
(defun plist-to-cmd-args (plist &aux args)
(doplist (k v plist args)
- (push (strcat "--" (string-downcase (symbol-name k)) "=" v) args)))
+ (push (strcat "--" (string-downcase (symbol-name k)) "=" v) args)))
;;;; Progress & debug printing
@@ -143,22 +143,22 @@ supported."
"Print something to the user during deploys."
(unless (and (numberp level) (> level *consfigurator-debug-level*))
(let ((lines (loop for line in (etypecase output
- (cons output)
- (string (lines output)))
- ;; strip (first part of) prefix added by a remote Lisp
- for stripped = (if (string-prefix-p ";; " line)
- (subseq line 3)
- line)
- unless (and strip-empty (re:scan #?/\A\s*\z/ stripped))
- collect stripped)))
+ (cons output)
+ (string (lines output)))
+ ;; strip (first part of) prefix added by a remote Lisp
+ for stripped = (if (string-prefix-p ";; " line)
+ (subseq line 3)
+ line)
+ unless (and strip-empty (re:scan #?/\A\s*\z/ stripped))
+ collect stripped)))
(when fresh-line
- (fresh-line)
- (princ *inform-prefix*))
+ (fresh-line)
+ (princ *inform-prefix*))
(princ (pop lines))
(dolist (line lines)
- (fresh-line)
- (princ *inform-prefix*)
- (princ line)))))
+ (fresh-line)
+ (princ *inform-prefix*)
+ (princ line)))))
(defun informat (level control-string &rest format-arguments)
"Print something to the user during deploys using FORMAT.
@@ -166,11 +166,11 @@ Be sure to begin CONTROL-STRING with ~& unless you want to continue from
previous output."
(if (string-prefix-p "~&" control-string)
(inform level
- (apply #'format nil (subseq control-string 2) format-arguments)
- :fresh-line t)
+ (apply #'format nil (subseq control-string 2) format-arguments)
+ :fresh-line t)
(inform level
- (apply #'format nil control-string format-arguments)
- :fresh-line nil)))
+ (apply #'format nil control-string format-arguments)
+ :fresh-line nil)))
;;;; Version numbers
@@ -189,14 +189,14 @@ previous output."
(defun dpkg-version-compare (x r y)
(zerop (nth-value 2 (run-program `("dpkg" "--compare-versions"
- ,(etypecase x
- (string x)
- (number (format nil "~A" x)))
- ,r
- ,(etypecase y
- (string y)
- (number (format nil "~A" y))))
- :ignore-error-status t))))
+ ,(etypecase x
+ (string x)
+ (number (format nil "~A" x)))
+ ,r
+ ,(etypecase y
+ (string y)
+ (number (format nil "~A" y))))
+ :ignore-error-status t))))
;;;; Encoding of strings to filenames
@@ -212,33 +212,33 @@ previous output."
(defun string->filename (s)
(apply #'concatenate 'string
- (loop for c
- across (etypecase s (string s) (number (write-to-string s)))
- if (or (char= c #\.)
- (alpha-char-p c)
- (digit-char-p c))
- collect (format nil "~C" c)
- else
- collect (format nil "_~X_" (char-code c)))))
+ (loop for c
+ across (etypecase s (string s) (number (write-to-string s)))
+ if (or (char= c #\.)
+ (alpha-char-p c)
+ (digit-char-p c))
+ collect (format nil "~C" c)
+ else
+ collect (format nil "_~X_" (char-code c)))))
(defun filename->string (s)
(loop with decoding
- with buffer
- with result
- for c across s
- do (cond
- ((and (char= c #\_) (not decoding))
- (setq decoding t))
- ((and (char= c #\_) decoding)
- (unless buffer (error "invalid encoding"))
- (push (code-char
- (read-from-string
- (coerce (list* #\# #\x (nreverse buffer)) 'string)))
- result)
- (setq buffer nil
- decoding nil))
- (decoding
- (push c buffer))
- (t
- (push c result)))
- finally (return (coerce (nreverse result) 'string))))
+ with buffer
+ with result
+ for c across s
+ do (cond
+ ((and (char= c #\_) (not decoding))
+ (setq decoding t))
+ ((and (char= c #\_) decoding)
+ (unless buffer (error "invalid encoding"))
+ (push (code-char
+ (read-from-string
+ (coerce (list* #\# #\x (nreverse buffer)) 'string)))
+ result)
+ (setq buffer nil
+ decoding nil))
+ (decoding
+ (push c buffer))
+ (t
+ (push c result)))
+ finally (return (coerce (nreverse result) 'string))))