thodg/cl-unix-cybernetics/core/probe.lisp

• Show log

  Commit

• Hash : 10f09333
  Author :
  Date : 2015-07-23T18:39:04
  

  Allow merging of specific property values.

Download

• core/probe.lisp

• ;;
  ;;  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)
  
  ;;  Probe methods
  
  (defmethod probe-generic-function ((probe probe))
    (symbol-function (probe-name probe)))
  
  (defmethod print-object ((probe probe) stream)
    (print-unreadable-object (probe stream :type t :identity (not *print-pretty*))
      (format stream "~S (~{~A~^ ~})"
  	    (probe-name probe)
  	    (probe-properties probe))))
  
  ;;  Relate probes to properties in each resource class
  
  (defmethod probe-class ((rc resource-class))
    'probe)
  
  (defmethod compute-probes ((rc resource-class))
    (iter (for class in (closer-mop:class-precedence-list rc))
          (for direct-probes = (when (typep class 'resource-class)
  			       (direct-probes class)))
  	(dolist (probe-definition direct-probes)
  	  (collect (apply #'make-instance
  			  (probe-class rc)
  			  :name probe-definition)))))
  
  (defmethod probe-properties ((rc resource-class))
    (let ((properties nil))
      (dolist (probe (probes-of rc))
        (dolist (property (probe-properties probe))
  	(pushnew property properties)))
      (sort properties #'string<)))
  
  ;;  Probing resources
  
  (defmethod probe-properties ((r resource))
    (probe-properties (class-of r)))
  
  (defmethod probes-of ((r resource))
    (probes-of (class-of r)))
  
  (defmethod find-probe ((r resource)
  		       (property symbol)
  		       os)
      (some (lambda (probe)
  	    (when (find property (probe-properties probe) :test #'eq)
  	      (let ((f (probe-generic-function probe)))
  		(when (compute-applicable-methods f (list r os))
  		  probe))))
  	  (probes-of r)))
  
  (defun add-probed-properties (resource properties)
    (setf #1=(probed-properties resource)
          (merge-properties resource #1# properties)))
  
  (defmethod probe ((r resource) (property symbol))
    (let* ((os (unless (and (typep r 'host)
                            (eq property :os))
                 (host-os (current-host))))
  	 (probe (or (find-probe r property os)
  		    (error 'resource-probe-not-found
  			   :resource r
  			   :property property
  			   :host (current-host)
  			   :os os)))
  	 (result (funcall (probe-generic-function probe) r os)))
      (when (eq +undefined+ (get-property property result))
        (error 'resource-probe-failed
  	     :probe probe
  	     :resource r
  	     :property property
  	     :host (current-host)
  	     :os os))
      (add-probed-properties r result)
      result))
  
  (defmethod get-probed ((r resource) (property symbol))
    (let ((value (get-property property (probed-properties r))))
      (when (eq +undefined+ value)
        (setq value (get-property property (probe r property))))
      value))
  
  (defmethod clear-probed% ((r resource) (properties null))
    (setf (probed-properties r) nil))
  
  (defmethod clear-probed% ((r resource) (property symbol))
    (remf* (probed-properties r) property))
  
  (defmethod clear-probed% ((r resource) (properties cons))
    (dolist (p properties)
      (when p
        (clear-probed r p))))
  
  (defun clear-probed (&optional (resource (localhost)) properties)
    (clear-probed% resource properties))
  
  ;;  Conditions
  
  (defmethod print-object ((c resource-probe-not-found) stream)
    (if *print-escape*
        (call-next-method)
        (with-slots (resource property host os) c
  	(format stream "Probe not found~%resource ~A~%property ~A~%host ~S~%~A"
  		resource property (hostname host)
  		(class-name (class-of os))))))
  
  (defmethod print-object ((c resource-probe-failed) stream)
    (if *print-escape*
        (call-next-method)
        (with-slots (probe resource property host os) c
  	(format stream "~A failed~%resource ~A~%property ~A~%host ~S~%~A"
  		(probe-name probe) resource property (hostname host)
  		(class-name (class-of os))))))
  

Download