thodg/cl-unix-cybernetics

diff --git a/resource.lisp b/resource.lisp
index 8793f89..818f84b 100644
--- a/resource.lisp
+++ b/resource.lisp
@@ -50,48 +50,25 @@
 ;;  Resource
 
 (defclass resource (standard-object)
-  ((name :type t
+  ((name :type string
 	 :initform (error "missing resource name")
-	 :initarg name
+	 :initarg :name
 	 :reader resource-name))
   (:metaclass resource-class))
 
 (defun make-resource (type name &rest properties)
-  (apply #'make-instance type 'name name properties))
-
-;;  Resource registration
-
-(defgeneric register-resource (resource))
-
-(defmethod register-resource ((res resource))
-  "FIXME: lock instances index"
-  (let ((name (resource-name res))
-	(index (resource-class-instances (class-of res))))
-    (assert (not (gethash name index)))
-    (setf (gethash name index) res)))
-
-(defun define-resource (type name &rest properties)
-  (let ((res (apply #'make-resource type name properties)))
-    (register-resource res)
-    res))
-
-(defgeneric find-resource (type name))
-
-(defmethod find-resource ((type class) (name string))
-  (gethash name (resource-class-instances type)))
-
-(defmethod find-resource ((type symbol) name)
-  (find-resource (find-class type) name))
+  (apply #'make-instance type :name name properties))
 
 ;;  Resource property
 
 (defun resource-property-slot-definition (resource property)
   (declare (type resource resource)
 	   (type symbol property))
-  (find-if (lambda (slot)
-	     (let ((key (car (closer-mop:slot-definition-initargs slot))))
-	       (eq property key)))
-	   (closer-mop:class-slots (class-of resource))))
+  (or (find-if (lambda (slot)
+		 (let ((key (car (closer-mop:slot-definition-initargs slot))))
+		   (eq property key)))
+	       (closer-mop:class-slots (class-of resource)))
+      (error "Property not found : ~S for ~S" property resource)))
 
 (defun resource-property-slot-name (resource property)
   (closer-mop:slot-definition-name
@@ -118,7 +95,8 @@
 (defmethod resource-properties ((class resource-class))
   (iter (for slot in (closer-mop:class-slots class))
         (for key = (car (closer-mop:slot-definition-initargs slot)))
-        (when (keywordp key)
+        (when (and (keywordp key)
+		   (not (eq :name key)))
 	  (collect key))))
 
 (defmethod resource-properties ((res resource))
@@ -129,7 +107,8 @@
 	    (let ((key (car (closer-mop:slot-definition-initargs slot)))
 		  (name (closer-mop:slot-definition-name slot)))
 	      (when (and (slot-boundp resource name)
-			 (keywordp key))
+			 (keywordp key)
+			 (not (eq :name key)))
 		(funcall fn key (slot-value resource name)))))
 	  (closer-mop:class-slots (class-of resource))))
 
@@ -167,16 +146,20 @@
        #1#
        (write-char #\Space s)))))
 
-;;  Gathering resource values
+;;  Gathering resource properties
 
 (defgeneric gather-resource-property (resource property))
 
+;;  Gathering resources
+
 (defgeneric gather-resource (type name))
 
 (defmethod gather-resource ((resource resource) (name t))
   (dolist (property (resource-properties resource))
-    (setf (slot-value resource property)
-	  (gather-resource-property resource property)))
+    (if (slot-boundp resource property)
+	(slot-value resource property)
+	(setf (slot-value resource property)
+	      (gather-resource-property resource property))))
   resource)
 
 (defmethod gather-resource ((type class) (name string))
@@ -187,6 +170,19 @@
     (setq type (find-symbol (symbol-name type) :adams)))
   (gather-resource (find-class type) name))
 
-;;  Ensuring resource values
+;;  Ensuring resource properties
+
+(defgeneric ensure-resource-property (spec property gathered))
+
+(defgeneric ensure-resource (spec))
 
-(defgeneric ensure-resource-property (resource property value))
+(defmethod ensure-resource ((resource resource))
+  (let ((gathered (gather-resource (class-of resource)
+				   (resource-name resource))))
+    (mapcan-resource-properties
+     (lambda (property spec-value)
+       (unless (and (slot-boundp gathered property)
+		    (equal spec-value
+			   (slot-value gathered property)))
+	 (ensure-resource-property spec property gathered)))
+     spec)))
diff --git a/unix.lisp b/unix.lisp
index 19f445e..64d0948 100644
--- a/unix.lisp
+++ b/unix.lisp
@@ -128,6 +128,20 @@
 
 ;;  File
 
+(define-resource-class file ()
+  ((type :type symbol)
+   (permissions :type string)
+   (owner :type (or string fixnum))
+   (group :type (or string fixnum))
+   (size :type integer)
+   (atime :type integer)
+   (mtime :type integer)
+   (ctime :type integer)
+   (blocks :type integer)
+   (md5 :type string)
+   (sha1 :type string)
+   (content :type string)))
+
 (define-constant +file-type-mode-bits+
     '((:fifo              . #o010000)
       (:character-special . #o020000)
@@ -169,31 +183,39 @@
   (values file dev ino mode nlink uid gid rdev size
 	  atime mtime ctime blksize blocks flags))
 
-(define-resource-class file ()
-  ((type :type symbol)
-   (permissions :type string)
-   (owner :type (or string fixnum))
-   (group :type (or string fixnum))
-   (size :type integer)
-   (atime :type integer)
-   (mtime :type integer)
-   (ctime :type integer)
-   (blocks :type integer)))
-
-(defmethod gather-resource ((resource file) name)
-  (iterate (stat<1> (name* dev* ino* mode* nlink* uid* gid* rdev* size*
-	             atime* mtime* ctime* blksize* blocks* flags*)
-		    in (stat name))
-	   (when (string= name name*)
-	     (with-slots (type permissions owner group
-			  size atime mtime ctime blocks) resource
+(defun gather-file-stat (resource)
+  (with-slots (name type permissions owner group
+		    size atime mtime ctime blocks) resource
+    (iterate (stat<1> (name* dev* ino* mode* nlink* uid* gid* rdev* size*
+			     atime* mtime* ctime* blksize* blocks* flags*)
+		      in (stat name))
+	     (when (string= name name*)
 	       (setf type (mode-file-type mode*)
 		     permissions (mode-permissions mode*)
 		     owner (gather-uid-user-name uid*)
 		     group (gather-gid-group-name gid*)
 		     size size* atime atime* mtime mtime* ctime ctime*
-		     blocks blocks*))
-	    (return resource))))
+		     blocks blocks*)
+	       (return resource)))))
+
+(define-syntax cksum<1> (algo sum file)
+    "(\\S+) \\((.*)\\) = (\\S+)"
+  "Syntax for cksum(1) output.")
+
+(defun gather-file-cksum (resource &rest algorithms)
+  (let ((name (resource-name resource)))
+    (iterate (cksum<1> (algo* file* sum*)
+		       in (run "cksum -a ~{~A~^,~} ~A"
+			       algorithms (sh-quote name)))
+	     (for algo = (find algo* algorithms
+			       :key #'symbol-name
+			       :test #'string-equal))
+	     (when (and algo (string= name file*))
+	       (setf (resource-property resource algo) sum*))))
+  resource)
+
+(defmethod gather-resource ((resource file) name)
+  (gather-file-stat resource))
 
 (defun permissions-mode-bits (s)
   (declare (type (string 9) s))
@@ -207,3 +229,12 @@
    (ecase (char s 6) (#\- 0) (#\r #o0004))
    (ecase (char s 7) (#\- 0) (#\w #o0002))
    (ecase (char s 8) (#\- 0) (#\x #o0001) (#\S #o1000) (#\s #o1001))))
+
+(defmethod (setf resource-property) :after ((value string)
+					    (resource file)
+					    (property (eql :content)))
+  (dolist (digest '(:md5 :sha1))
+    (setf (resource-property resource digest)
+	  (ironclad:digest-sequence
+	   digest
+	   (trivial-utf-8:string-to-utf-8-bytes value)))))