diff options
| -rw-r--r-- | src/combinator.lisp | 121 | ||||
| -rw-r--r-- | src/package.lisp | 2 | ||||
| -rw-r--r-- | src/property.lisp | 12 | ||||
| -rw-r--r-- | src/util.lisp | 4 |
4 files changed, 96 insertions, 43 deletions
diff --git a/src/combinator.lisp b/src/combinator.lisp index 352ae46..772ac6c 100644 --- a/src/combinator.lisp +++ b/src/combinator.lisp @@ -65,32 +65,37 @@ Usage notes: (propappunapply (choose-propapp)))))) (setf (get ',name 'inline-combinator) t))) -(defun skip-property-restarts () - (loop for restart in (compute-restarts) - when (eql 'skip-property (restart-name restart)) - collect restart)) - -;; There can be multiple SKIP-PROPERTY restarts established at once, and we -;; need this handler to invoke the one established right after we establish -;; this handler. -(defmacro with-skip-failed-changes (&body forms) - (with-gensyms (old-restarts) - `(let ((,old-restarts (skip-property-restarts))) - (handler-bind ((failed-change - (lambda (c) - (with-indented-inform - (apply #'informat t - (simple-condition-format-control c) - (simple-condition-format-arguments c))) - ;; We can't just use NSET-DIFFERENCE and take the - ;; LASTCAR because NSET-DIFFERENCE provides no - ;; ordering guarantees. - (loop with chosen - for restart in (skip-property-restarts) - unless (member restart ,old-restarts) - do (setq chosen restart) - finally (invoke-restart chosen))))) - ,@forms)))) +;; There can be multiple SKIP-* restarts with the same name established at +;; once, and we need this handler to invoke one of the four established by the +;; call to APPLY-AND-PRINT right after we establish this handler. +(defmacro with-skip-failed-changes + ((&key (condition ''failed-change) (restart ''skip-property)) &body forms) + (once-only (condition restart) + (with-gensyms (old-restarts) + `(let* ((,old-restarts + (loop for restart + in (compute-restarts (make-condition ,condition)) + when (eql (restart-name restart) ,restart) + collect restart))) + (handler-bind + ((failed-change + (lambda (c) + (when (subtypep (type-of c) ,condition) + (with-indented-inform + (apply #'informat t + (simple-condition-format-control c) + (simple-condition-format-arguments c))) + ;; We can't just use NSET-DIFFERENCE and take the + ;; LASTCAR because NSET-DIFFERENCE provides no ordering + ;; guarantees. + (loop with chosen and old-restarts = ,old-restarts + for restart in (compute-restarts c) + if (eql restart (car old-restarts)) + do (pop old-restarts) + else if (eql (restart-name restart) ,restart) + do (setq chosen restart) + finally (invoke-restart chosen)))))) + ,@forms))))) (define-function-property-combinator eseqprops (&rest propapps) (:retprop :type (collapse-types (mapcar #'propapptype propapps)) @@ -98,14 +103,28 @@ Usage notes: :apply (lambda () (apply-and-print propapps)) :unapply (lambda () (apply-and-print propapps t)))) +(define-function-property-combinator eseqprops-until (condition &rest propapps) + "Like ESEQPROPS, but if CONDITION is signalled, handle it simply by skipping +remaining elements of PROPAPPS. CONDITION must subtype FAILED-CHANGE." + (:retprop :type (collapse-types (mapcar #'propapptype propapps)) + :hostattrs (lambda () (mapc #'propappattrs propapps)) + :apply (lambda () + (with-skip-failed-changes (:condition condition + :restart 'skip-sequence) + (apply-and-print propapps))) + :unapply (lambda () + (with-skip-failed-changes (:condition condition + :restart 'skip-sequence) + (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 + (with-skip-failed-changes () (apply-and-print propapps))) :unapply (lambda () - (with-skip-failed-changes + (with-skip-failed-changes () (apply-and-print propapps t))))) (defmacro with-requirements (propapp &body requirements) @@ -118,10 +137,10 @@ apply the elements of REQUIREMENTS in reverse order." (:retprop :type (collapse-types (mapcar #'propapptype propapps)) :hostattrs (lambda () (mapc #'propappattrs propapps)) :apply (lambda () - (with-skip-failed-changes + (with-skip-failed-changes () (apply-and-print propapps nil t))) :unapply (lambda () - (with-skip-failed-changes + (with-skip-failed-changes () (apply-and-print propapps t t))))) (defun apply-and-print @@ -160,8 +179,21 @@ apply the elements of REQUIREMENTS in reverse order." (informat t "~&~@[~A :: ~]~@[~A ... ~]~A~%" (get-hostname) (propappdesc propapp) status)) ;; Ensure POST-APPLY called exactly once for each propapp. - (setq propapp nil)))) + (setq propapp nil))) + + (test (c) (subtypep (type-of c) 'aborted-change)) + (ntest (c) (not (subtypep (type-of c) 'aborted-change))) + + (pareport (s) + (format s "Skip (~{~S~^ ~})" + (cons (car propapp) (propappargs propapp)))) + (seqreport (s) + (format s "Skip remainder of sequence containing (~{~S~^ ~})" + (cons (car propapp) (propappargs propapp))))) (unwind-protect + ;; Establish restarts to be invoked by WITH-SKIP-FAILED-CHANGES + ;; or possibly interactively by the user. There are two of each + ;; because we want to handle ABORTED-CHANGE specially. (restart-case (alet (if announce (with-output-to-string (*standard-output* buffer) @@ -174,14 +206,25 @@ apply the elements of REQUIREMENTS in reverse order." (propappapply propapp))) (accumulate it) (post-apply (if (eql it :no-change) "ok" "done"))) - (skip-property () - :report (lambda (s) - (format s "Skip (~{~S~^ ~})" - (cons (car propapp) - (propappargs propapp)))) - (signal 'skipped-properties) - (post-apply "failed") - (accumulate nil))) + ;; Standard restarts for skipping over sequence entries. + (skip-property () :test ntest :report pareport + (signal 'skipped-properties) (post-apply "failed") + (accumulate nil)) + (skip-property () :test test :report pareport + (signal 'skipped-properties) (post-apply "failed") + (accumulate :no-change)) + ;; Special restarts for the whole sequence which return from + ;; the enclosing DOLIST based on the kind of error. If + ;; ABORTED-CHANGE, we assume that applying the current propapp + ;; made no change, so we return a value indicating whether + ;; properties earlier in PROPAPPS made a change. Otherwise, we + ;; assume that some change was made. + (skip-sequence () :test ntest :report seqreport + (signal 'skipped-properties) (post-apply "failed") + (return)) + (skip-sequence () :test test :report seqreport + (signal 'skipped-properties) (post-apply "failed") + (return return-value))) ;; Ensure we print out the buffer contents if due to a non-local ;; exit neither of the other calls to POST-APPLY have been made. (post-apply "failed")) diff --git a/src/package.lisp b/src/package.lisp index 748b45d..a779fca 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -195,6 +195,7 @@ #:get-short-hostname #:require-data #:failed-change + #:aborted-change #:assert-euid-root #:assert-connection-supports #:maybe-writefile-string @@ -222,6 +223,7 @@ #:define-choosing-property-combinator #:seqprops #:eseqprops + #:eseqprops-until #:with-requirements #:silent-seqprops #:unapply diff --git a/src/property.lisp b/src/property.lisp index b43fe8c..660a23e 100644 --- a/src/property.lisp +++ b/src/property.lisp @@ -473,7 +473,7 @@ other than constant values and propapps to property combinators." ;;;; hostattrs in property subroutines -(define-simple-error inapplicable-property +(define-simple-error inapplicable-property () "Signal, in a :HOSTATTRS subroutine, that the host's hostattrs indicate that this property cannot be applied to this host. E.g. the property will try to install an apt package but the host is FreeBSD.") @@ -553,10 +553,18 @@ Called by property subroutines." ;;;; :APPLY subroutines -(define-simple-error failed-change +(define-simple-error failed-change () "Signal problems with the connection and errors while actually attempting to apply or unapply properties.") +(define-simple-error aborted-change (failed-change) + "Like FAILED-CHANGE, except the attempt to apply or unapply the property has +failed before any changes have been made to the system. Signalled when a +property is able to determine that it cannot be applied/unapplied by examining +the actual state of the host but without making any changes. + +Not to be confused with INAPPLICABLE-PROPERTY.") + (defun maybe-writefile-string (path content &key (mode nil mode-supplied-p)) "Wrapper around WRITEFILE which returns :NO-CHANGE and avoids writing PATH if PATH already has the specified CONTENT and MODE." diff --git a/src/util.lisp b/src/util.lisp index f23cfb0..487fcd4 100644 --- a/src/util.lisp +++ b/src/util.lisp @@ -149,9 +149,9 @@ supported." (nreversef ,argsym) ,@forms))))) -(defmacro define-simple-error (name &optional docstring) +(defmacro define-simple-error (name &optional parent-types docstring) `(progn - (define-condition ,name (simple-error) () + (define-condition ,name (,@parent-types simple-error) () ,@(and docstring `((:documentation ,docstring)))) (defun ,name (message &rest args) ,@(and docstring `(,docstring)) |