Commit e465e299030b0bec1d9cef78d878822c689b94d5

Thomas de Grivel 2014-12-17T00:05:17

Fix probes.

diff --git a/core/defs.lisp b/core/defs.lisp
index f89991b..17836f5 100644
--- a/core/defs.lisp
+++ b/core/defs.lisp
@@ -102,6 +102,8 @@
 		      :accessor probed-properties))
   (:metaclass resource-class))
 
+(defgeneric resource-probes-properties (resource))
+
 (setq *the-resource-class* (find-class 'resource))
 
 ;;  Resource registry
@@ -146,6 +148,27 @@
 	    :reader os-version
 	    :type string)))
 
+;;  Host
+
+(define-resource-class host (resource-tree)
+  ((shell :initarg :shell
+	  :type shell))
+  ((probe-os-using-uname :properties (os))
+   (probe-hostname :properties (hostname))
+   (probe-uptime :properties (uptime))))
+
+(defgeneric host-connect (host))
+(defgeneric host-disconnect (host))
+(defgeneric host-shell (host))
+(defgeneric (setf host-shell) (shell host))
+
+(defgeneric host-run (host command &rest format-args))
+
+(define-resource-class ssh-host (host))
+
+(defvar *localhost*)
+(defvar *host*)
+
 ;;  Probing resources
 
 (define-condition resource-probe-error (error)
@@ -166,31 +189,3 @@
 (defgeneric get-probed (resource property))
 
 (defvar *resource*)
-
-;;  BSD cksum
-
-(defvar *cksum-algorithms*
-  '(cksum md4 md5 rmd160 sha1 sha224 sha256 sha384 sha512 sum sysvsum))
-
-;;  Host
-
-(define-resource-class host (resource-tree)
-  ((shell :initarg :shell
-	  :type shell))
-  ((probe-os-using-uname :properties (os))
-   (probe-hostname :properties (hostname))
-   (probe-uptime :properties (uptime))))
-
-(defgeneric host-connect (host))
-(defgeneric host-disconnect (host))
-(defgeneric host-shell (host))
-(defgeneric (setf host-shell) (shell host))
-
-(defgeneric host-run (host command &rest format-args))
-
-(define-resource-class ssh-host (host)
-  ()
-  ())
-
-(defvar *localhost*)
-(defvar *host*)
diff --git a/core/host.lisp b/core/host.lisp
index 23f7df1..bf4b5bb 100644
--- a/core/host.lisp
+++ b/core/host.lisp
@@ -94,7 +94,7 @@
 	    name release machine version))))
 
 (defmethod host-os ((host host))
-  (getf (probed-properties host) 'os))
+  (get-probed host 'os))
 
 ;;  Host probes
 
diff --git a/core/resource.lisp b/core/resource.lisp
index 47ba8a6..a061fda 100644
--- a/core/resource.lisp
+++ b/core/resource.lisp
@@ -38,6 +38,24 @@
 (defun resource-type (resource)
   (class-name (class-of resource)))
 
+(defmethod resource-probes-properties ((res resource))
+  (let ((properties))
+    (dolist (probe (probes-of res))
+      (dolist (property (probe-properties probe))
+        (pushnew property properties)))
+    (sort properties #'string<)))
+
+#+nil
+(resource-probes-properties (resource 'file "/"))
+
+(defun probe-all-properties (res)
+  (dolist (p (resource-probes-properties res))
+    (get-probed res p))
+  (probed-properties res))
+
+#+nil
+(probe-all-properties (resource 'file "/"))
+
 ;;  Resource tree
 
 (defmethod print-object ((r resource-tree) stream)
diff --git a/package.lisp b/package.lisp
index b567acd..6ab296e 100644
--- a/package.lisp
+++ b/package.lisp
@@ -96,6 +96,7 @@
    #:host
    #:host-connect
    #:host-disconnect
+   #:host-os
    #:host-shell
    #:host-run
    #:*localhost*
diff --git a/unix/defs.lisp b/unix/defs.lisp
index f104b15..189ec7e 100644
--- a/unix/defs.lisp
+++ b/unix/defs.lisp
@@ -29,8 +29,14 @@
 (define-resource-class vnode ()
   ()
   ((probe-vnode-using-ls :properties (mode links owner group size mtime))
-   (probe-vnode-using-stat :properties (type permissions owner group size
-					     atime mtime ctime blocks))))
+   (probe-vnode-using-stat :properties (dev ino mode links uid gid rdev size
+                                        atime mtime ctime blksize blocks flags))))
+
+(defvar *cksum-legacy-algorithms*
+  '(cksum sum sysvsum))
+
+(defvar *cksum-algorithms*
+  `(md4 md5 rmd160 sha1 sha224 sha256 sha384 sha512 ,@*cksum-legacy-algorithms*))
 
 (define-resource-class file (vnode)
   ()
diff --git a/unix/probes.lisp b/unix/probes.lisp
index 64e4406..2fab04c 100644
--- a/unix/probes.lisp
+++ b/unix/probes.lisp
@@ -100,14 +100,27 @@
 
 #.(cons 'progn
 	(iter (for algorithm in *cksum-algorithms*)
+              (for legacy = (member algorithm *cksum-legacy-algorithms*))
 	      (for name = (sym 'probe-file-cksum- algorithm))
 	      (collect `(defgeneric ,name (file os)))
 	      (collect `(defmethod ,name ((file file) (os os-unix))
 			  (let ((id (resource-id file)))
-			    (iter (cksum<1> (algo name sum)
-					    in (run "cksum -a ~A ~A"
-						    ',algorithm
-						    (sh-quote id)))
-				  (when (and (string= ',algorithm algo)
-					     (string= id name))
+			    (iter (,(if legacy 'cksum<1>-legacy 'cksum<1>)
+                                    ,(if legacy
+                                         '(sum size name)
+                                         '(algo name sum))
+                                    in (run ,(str "cksum -a " algorithm " ~A")
+                                            (sh-quote id)))
+				  (when ,(if legacy
+                                             `(string= id name)
+                                             `(and (string= ',algorithm algo)
+                                                   (string= id name)))
 				    (return (list ',algorithm sum)))))))))
+
+(defgeneric probe-file-content (file os))
+
+(defvar *probe-file-content-size-limit* 8192)
+
+(defmethod probe-file-content ((file file) (os os-unix))
+  (when (< (get-probed file 'size) *probe-file-content-size-limit*)
+    (list 'content (run "cat ~A" (sh-quote (resource-id file))))))
diff --git a/unix/syntaxes.lisp b/unix/syntaxes.lisp
index d3c2a99..afb1492 100644
--- a/unix/syntaxes.lisp
+++ b/unix/syntaxes.lisp
@@ -77,6 +77,10 @@
   (values file dev ino mode links uid gid rdev size
 	  atime mtime ctime blksize blocks flags))
 
+(define-syntax cksum<1>-legacy (sum size file)
+    #~|(\S+) (\S+) (\S+)|
+  "Syntax for cksum(1) legacy output.")
+
 (define-syntax cksum<1> (algo sum file)
     #~|(\S+) \((.*)\) = (\S+)|
   "Syntax for cksum(1) output.")