Commit 8dc1ded64c12727fc5b749ec2b1096aa69188398
2015-08-01T04:35:42
fix op
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119
diff --git a/core/operation.lisp b/core/operation.lisp
new file mode 100644
index 0000000..c71f5d4
--- /dev/null
+++ b/core/operation.lisp
@@ -0,0 +1,113 @@
+;;
+;; adams - Remote system administration tools
+;;
+;; Copyright 2013,2014 Thomas de Grivel <thomas@lowh.net>
+;;
+;; Permission to use, copy, modify, and distribute this software for any
+;; purpose with or without fee is hereby granted, provided that the above
+;; copyright notice and this permission notice appear in all copies.
+;;
+;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+;;
+
+(in-package :adams)
+
+;; Operation methods
+
+(defmethod operation-generic-function ((op operation))
+ (symbol-function (operation-name op)))
+
+(defmethod print-object ((op operation) stream)
+ (print-unreadable-object (op stream :type t :identity (not *print-pretty*))
+ (format stream "~S (~{~A~^ ~})"
+ (operation-name op)
+ (operation-properties op))))
+
+;; Relate operations to properties in each resource class
+
+(defmethod operation-class ((rc resource-class))
+ 'operation)
+
+(defmethod compute-operations ((rc resource-class))
+ (iter (for class in (closer-mop:class-precedence-list rc))
+ (for direct-ops = (when (typep class 'resource-class)
+ (direct-operations class)))
+ (dolist (op-definition direct-ops)
+ (collect (apply #'make-instance
+ (operation-class rc)
+ :name
+ op-definition)))))
+
+(defmethod operation-properties ((rc resource-class))
+ (let ((properties nil))
+ (dolist (op (operations-of rc))
+ (dolist (property (operation-properties op))
+ (pushnew property properties)))
+ (sort properties #'string<)))
+
+;; Probing resources
+
+(defmethod operation-properties ((r resource))
+ (operation-properties (class-of r)))
+
+(defmethod operations-of ((r resource))
+ (operations-of (class-of r)))
+
+(defmethod find-operation ((r resource)
+ (property symbol)
+ os)
+ (some (lambda (op)
+ (when (find property (operation-properties op) :test #'eq)
+ (let ((f (operation-generic-function op)))
+ (when (compute-applicable-methods f (list r os))
+ op))))
+ (operations-of r)))
+
+(defun list-operations (res plist os)
+ (iter (for* (property value) in plist)
+ (adjoining (or (find-operation res property os)
+ (error 'resource-operation-not-found
+ :resource res
+ :property property
+ :host (current-host)
+ :os os)))))
+
+(defun sort-operations (operations)
+ (sort operations (lambda (op1 op2)
+ (find op1 (operations-before op2)))))
+
+(defmethod operate ((res resource) (plist list))
+ (let* ((os (host-os (current-host)))
+ (operations (list-operations res plist os))
+ (sorted-ops (sort-operations operations)))
+ (iter (for op in sorted-ops)
+ (collect (apply (operation-generic-function op)
+ res os plist)))))
+
+;; Conditions
+
+(defmethod print-object ((c resource-operation-not-found) stream)
+ (if *print-escape*
+ (call-next-method)
+ (with-slots (resource property host os) c
+ (format stream "Operation not found~%resource ~A~%property ~A~%host ~S~%~A"
+ resource property (hostname host)
+ (class-name (class-of os))))))
+
+(defmethod print-object ((c resource-operation-failed) stream)
+ (if *print-escape*
+ (call-next-method)
+ (with-slots (operation resource diff host os) c
+ (format stream "~A failed for (resource '~A ~S) on (host ~S) ~A.~%Conflicting values :~%~{ ~A~% expected ~S~% probed ~S~%~}"
+ (operation-name operation)
+ (string-downcase (class-name (class-of resource)))
+ (resource-id resource)
+ (hostname host)
+ (class-name (class-of os))
+ diff))))