cl-adams/adams

diff --git a/adams.asd b/adams.asd
index 9ec18c9..e65ba03 100644
--- a/adams.asd
+++ b/adams.asd
@@ -27,12 +27,15 @@
   :version "0.1"
   :description "Remote system administration tools"
   :depends-on ("alexandria"
+	       "chronicity"
 	       "cl-base64"
 	       "cl-debug"
 	       "cl-ppcre"
 	       "closer-mop"
 	       "ironclad"
 	       "iterate"
+	       "re"
+	       "str"
 	       "trivial-utf-8")
   :components
   ((:file "package")
@@ -41,7 +44,7 @@
 	    ((:file "shell")
 	     #+sbcl
 	     (:file "sb-shell" :depends-on ("shell"))))
-   (:file "resource" :depends-on ("shell"))
-   (:file "manifest" :depends-on ("resource"))
-   (:file "host" :depends-on ("manifest"))
+   (:file "host" :depends-on ("shell"))
+   (:file "os" :depends-on ("host"))
+   (:file "resource" :depends-on ("os"))
    (:file "unix" :depends-on ("resource"))))
diff --git a/host.lisp b/host.lisp
index f599136..febf4f5 100644
--- a/host.lisp
+++ b/host.lisp
@@ -18,17 +18,38 @@
 
 (in-package :adams)
 
+;;  OS
+
+(defclass os ()
+  ((machine :initarg :machine
+	    :reader os-machine
+	    :type string)
+   (name :initarg :name
+	 :reader os-name
+	 :type string)
+   (release :initarg :release
+	    :reader os-release
+	    :type string)
+   (version :initarg :version
+	    :reader os-version
+	    :type string)))
+
+(defmethod print-object ((os os) stream)
+  (print-unreadable-object (os stream :type t :identity (not *print-pretty*))
+    (with-slots (machine name release version) os
+    (format stream "~A ~A ~A ~A"
+	    name release machine version))))
+
 ;;  Host
 
 (defclass host ()
-  ((name :type string
-	 :initarg :hostname
-	 :reader hostname)
-   (shell :type shell
-	  :initarg :shell)
-   (manifest :type manifest
-	     :initarg :manifest
-	     :reader host-manifest)))
+  ((name :initarg :hostname
+	 :reader hostname
+	 :type string)
+   (shell :initarg :shell
+	  :type shell)
+   (os :reader host-os
+       :type os)))
 
 (defmethod print-object ((host host) stream)
   (print-unreadable-object (host stream :type t :identity t)
@@ -72,11 +93,6 @@
   (with-connected-host (host hostname)
     (apply #'host-run host command format-args)))
 
-;;  Host manifest
-
-(defmethod slot-unbound (class (host host) (slot-name (eql 'manifest)))
-  (setf (slot-value host 'manifest) (manifest (hostname host))))
-
 ;;  localhost
 
 (defvar *localhost* (load-time-value
diff --git a/os.lisp b/os.lisp
new file mode 100644
index 0000000..dfca549
--- /dev/null
+++ b/os.lisp
@@ -0,0 +1,87 @@
+;;
+;;  adams  -  Remote system administration tools
+;;
+;;  Copyright 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)
+
+(enable-re-syntax)
+
+;;  UNIX
+
+(defclass os-unix (os)
+  ())
+
+;;  Linux
+
+(defclass os-linux (os-unix)
+  ())
+
+;;  BSD
+
+(defclass os-bsd (os-unix)
+  ())
+
+(defclass os-freebsd (os-bsd)
+  ())
+
+(defclass os-openbsd (os-bsd)
+  ())
+
+(defclass os-darwin (os-bsd)
+  ())
+
+;;  Windows
+
+(defclass os-windows (os)
+  ())
+
+;;  OS detection
+
+(defun uname ()
+  (let ((uname-a (first (run "uname -a"))))
+    (flet ((try-re (re)
+	     (re-bind re (os-name node-name os-release os-version machine) uname-a)))
+      (try-re #~"^(\S+) (\S+) (\S+) (.+) (\S+)$"))))
+
+(defun make-os ()
+  (multiple-value-bind (name hostname release version machine) (uname)
+    (declare (ignore hostname))
+    (let ((class (flet ((try (&rest parts)
+			  (when-let ((s (find-symbol (string-upcase (str 'os- parts))
+						     #.*package*)))
+			    (ignore-errors (find-class s)))))
+		   (or (try name '- release '- machine '- version)
+		       (try name '- release '- machine)
+		       (try name '- release '- version)
+		       (try name '- release)
+		       (try name '- machine '- version)
+		       (try name '- machine)
+		       (try name '- version)
+		       (try name)
+		       (error "Unknown OS : ~A" name)))))
+      (make-instance class
+		     :machine machine
+		     :name name
+		     :release release
+		     :version version))))
+
+(defun os ()
+  (if (slot-boundp *host* 'os)
+      #1=(slot-value *host* 'os)
+      (setf #1# (make-os))))
+
+(disable-re-syntax)
diff --git a/package.lisp b/package.lisp
index 71f0127..3037a62 100644
--- a/package.lisp
+++ b/package.lisp
@@ -19,7 +19,7 @@
 (in-package :cl-user)
 
 (defpackage :adams
-  (:use :alexandria :cl :debug :iterate)
+  (:use :alexandria :cl :debug :iterate :re :str)
   (:export
    ;;  Shell
    #:*default-shell-command*
diff --git a/resource.lisp b/resource.lisp
index 818f84b..f3fbc87 100644
--- a/resource.lisp
+++ b/resource.lisp
@@ -18,171 +18,156 @@
 
 (in-package :adams)
 
-;;  Resource class
+(unless (boundp '+undefined+)
+  (defconstant +undefined+ '#:undefined))
 
-(defclass resource-class (standard-class)
-  ((instances :type hash-table
-	      :initform (make-hash-table :test 'equal)
-	      :reader resource-class-instances)))
+;;  Probe
+
+(defclass probe ()
+  ((name :initarg :name
+	 :initform (error "Probe without a name.")
+	 :reader probe-name
+	 :type symbol)
+   (properties :initarg :properties
+	       :initform (error "Probe without properties.")
+	       :reader probe-properties)))
+
+(defgeneric probe-generic-function (probe))
+
+(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))))
+
+;;  Resource meta class
 
-(defmethod resource-class-instances ((class-name symbol))
-  (resource-class-instances (find-class class-name)))
+(defvar *the-resource-class*)
+
+(defclass resource-class (standard-class)
+  ((direct-probes :initarg :direct-probes
+		  :initform ()
+		  :reader resource-class-direct-probes
+		  :type list)
+   (probes :initarg :direct-probes
+	   :initform ()
+	   :reader resource-class-probes
+	   :type list))
+  (:default-initargs :direct-superclasses (list *the-resource-class*)))
 
 (defmethod closer-mop:validate-superclass ((class resource-class)
 					   (super standard-class))
   t)
 
-(defun resource-class-slot (name &rest rest &key initarg &allow-other-keys)
-  (list* name
-	 :initarg (or initarg
-		      (intern (symbol-name name) :keyword))
-	 rest))
+(defgeneric resource-class-probe-class (resource-class))
+
+(defmethod resource-class-probe-class ((resource-class resource-class))
+  'probe)
+
+(defgeneric compute-probes (resource-class))
+
+(defmethod compute-probes ((resource-class resource-class))
+  (iter (for class in (closer-mop:class-precedence-list resource-class))
+        (for direct-probes = (when (typep class 'resource-class)
+			       (resource-class-direct-probes class)))
+	(dolist (probe-definition direct-probes)
+	  (collect (apply #'make-instance
+			  (resource-class-probe-class resource-class)
+			  :name probe-definition)))))
+
+(defmethod closer-mop:finalize-inheritance :after ((resource-class resource-class))
+  (setf (slot-value resource-class 'probes)
+	(compute-probes resource-class)))
 
 (defmacro define-resource-class (name direct-superclasses
-				 direct-slots
+				 direct-slots direct-probes
 				 &optional options)
   `(defclass ,name ,(or direct-superclasses
 			'(resource))
-     ,(mapcar (lambda (x) (apply #'resource-class-slot x))
-	      direct-slots)
-     (:metaclass resource-class ,@options)))
+     ,direct-slots
+     (:metaclass resource-class)
+     (:direct-probes ,@direct-probes)
+     ,@options))
 
-;;  Resource
+;;  Resources
 
 (defclass resource (standard-object)
-  ((name :type string
-	 :initform (error "missing resource name")
-	 :initarg :name
-	 :reader resource-name))
+  ((id :type atom
+       :initarg :id
+       :initform (error "Missing ID for resource.")
+       :reader resource-id)
+   (specified-properties :type list
+			 :initarg :specified-properties
+			 :initform nil
+			 :reader specified-properties)
+   (probed-properties :type list
+		      :initarg :probed-properties
+		      :initform nil
+		      :reader probed-properties))
   (:metaclass resource-class))
 
-(defun make-resource (type name &rest properties)
-  (apply #'make-instance type :name name properties))
-
-;;  Resource property
-
-(defun resource-property-slot-definition (resource property)
-  (declare (type resource resource)
-	   (type symbol property))
-  (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
-   (resource-property-slot-definition resource property)))
-
-(defgeneric resource-property (resource property))
-
-(defmethod resource-property ((resource resource)
-			      (property symbol))
-  (slot-value resource (resource-property-slot-name resource property)))
-
-(defgeneric (setf resource-property) (new-value resource property))
-
-(defmethod (setf resource-property) (new-value
-				     (resource resource)
-				     (property symbol))
-  (setf (slot-value resource (resource-property-slot-name resource property))
-	new-value))
-
-;;  Resource properties
-
-(defgeneric resource-properties (resource))
-
-(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 (and (keywordp key)
-		   (not (eq :name key)))
-	  (collect key))))
-
-(defmethod resource-properties ((res resource))
-  (resource-properties (class-of res)))
-
-(defun mapcan-resource-properties (fn resource)
-  (mapcan (lambda (slot)
-	    (let ((key (car (closer-mop:slot-definition-initargs slot)))
-		  (name (closer-mop:slot-definition-name slot)))
-	      (when (and (slot-boundp resource name)
-			 (keywordp key)
-			 (not (eq :name key)))
-		(funcall fn key (slot-value resource name)))))
-	  (closer-mop:class-slots (class-of resource))))
-
-;;  Resource printing
-
-(defun serialize-resource (resource)
-  (let ((resource-class (class-of resource)))
-    (list* 'make-instance
-	   `',(class-name resource-class)
-	   (resource-name resource)
-	   (mapcan-resource-properties #'list resource))))
-
-(defgeneric print-resource-property (resource property value stream))
-
-(defmethod print-resource-property (resource property value stream)
-  (format stream "~S" value))
-
-(defmethod print-object ((res resource) s)
-  (cond
-    (*print-readably*
-     (format s "(~W '~W ~W" 'make-instance (class-name (class-of res))
-	     (resource-name res))
-     #1=(pprint-logical-block (s (mapcan-resource-properties #'list res))
-	  (iter (initially (pprint-exit-if-list-exhausted))
-		(for property = (pprint-pop))
-		(pprint-newline :fill s)
-		(write-char #\Space s)
-		(write property :stream s)
-		(write-char #\Space s)
-		(print-resource-property res property (pprint-pop) s)
-		(pprint-exit-if-list-exhausted))))
-    (:otherwise
-     (print-unreadable-object (res s :type t :identity t)
-       (write (resource-name res) :stream s)
-       #1#
-       (write-char #\Space s)))))
-
-;;  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))
-    (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))
-  (gather-resource (make-resource type name) name))
-
-(defmethod gather-resource ((type symbol) name)
-  (when (keywordp type)
-    (setq type (find-symbol (symbol-name type) :adams)))
-  (gather-resource (find-class type) name))
-
-;;  Ensuring resource properties
-
-(defgeneric ensure-resource-property (spec property gathered))
-
-(defgeneric ensure-resource (spec))
-
-(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)))
+(setq *the-resource-class* (find-class 'resource))
+
+(defmethod print-object ((res resource) stream)
+  (print-unreadable-object (res stream :type t :identity *print-readably*)
+    (format stream "~S ~D ~D" (resource-id res)
+	    (/ (length (specified-properties res)) 2)
+	    (/ (length (probed-properties res)) 2))))
+
+;;  Probes
+
+(defun os-class (os)
+  (etypecase os
+    (null t)
+    ((eql t) t)
+    (symbol (find-class os))
+    (os (class-of os))
+    (standard-class os)))
+
+(defgeneric find-probe (resource property os))
+
+(defmethod find-probe ((resource 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 resource os))
+		  f))))
+	  (resource-class-probes (class-of resource))))
+
+(defgeneric probe (resource property))
+
+(defmethod probe ((resource resource) (property symbol))
+  (with-slots (probed-properties) resource
+    (let* ((os (os))
+	   (probe (or (find-probe resource property os)
+		      (error "No probe found for ~S property ~S on ~A"
+			     resource property (class-name (class-of os)))))
+	   (result (funcall probe resource os)))
+      (when (eq +undefined+ (getf result property +undefined+))
+	(error "Probe did not return expected property.~%~
+                resource: ~S~%~
+                property: ~S~%~
+                probe: ~S~%~
+                result: ~S"
+	       resource property probe result))
+      (setf probed-properties
+	    (append result probed-properties))
+      result)))
+
+(defgeneric get-probed (resource property))
+
+(defmethod get-probed ((resource resource) (property symbol))
+  (let ((value (getf (probed-properties resource) property +undefined+)))
+    (when (eq +undefined+ value)
+      (setq value (getf (probe resource property) property +undefined+)))
+    (when (eq +undefined+ value)
+      (error "Probe did not return expected property."))
+    value))
+
+(defun make-resource (type id &rest initargs &key &allow-other-keys)
+  (apply #'make-instance type :id id initargs))
diff --git a/shell/shell.lisp b/shell/shell.lisp
index f1523a9..b268bca 100644
--- a/shell/shell.lisp
+++ b/shell/shell.lisp
@@ -24,9 +24,6 @@
 
 ;;  String functions
 
-(defun str (&rest args)
-  (apply #'concatenate 'string args))
-
 (defun read-string (stream)
   (with-output-to-string (out)
     (do ((c #1=(when (listen stream)
diff --git a/unix.lisp b/unix.lisp
index 64d0948..b6c38e1 100644
--- a/unix.lisp
+++ b/unix.lisp
@@ -18,16 +18,29 @@
 
 (in-package :adams)
 
-;;  Timestamp
-
-(defconstant +timestamp-offset+
-  (encode-universal-time 0 0 0 1 1 1970 0))
-
-(defun timestamp-to-universal-time (timestamp)
-  (+ timestamp +timestamp-offset+))
-
-(defun universal-time-to-timestamp (ut)
-  (- ut +timestamp-offset+))
+(enable-re-syntax)
+
+;;  Simple regexp-based parser generator with ITERATE support
+
+(defmacro define-syntax (name vars re &body body)
+  (let ((parse-name (sym 'parse- name))
+	(doc (when (stringp (first body)) (pop body)))
+	(values (or (first (last body))
+		    `(values ,@(iter (for spec in vars)
+				     (if (consp spec)
+					 (dolist (var (cdr spec))
+					   (collect var))
+					 (collect spec)))))))
+    `(progn
+       (defun ,parse-name (line)
+	 ,@(when doc (list doc))
+	 (re-bind ,re ,vars line
+	   ,@(or body `(,values))))
+       (iterate:defmacro-clause (,name iter-vars in lines)
+	 ,@(when doc (list doc))
+	 (let ((line (gensym ,(format nil "~A-LINE-" (symbol-name name)))))
+	   `(progn (for ,line in ,lines)
+		   (for (values ,@iter-vars) = (,',parse-name ,line))))))))
 
 ;;  Standard commands
 
@@ -37,188 +50,125 @@
 (defun egrep (pattern &rest files)
   (run "egrep ~A~{ ~A~}" (sh-quote pattern) (mapcar #'sh-quote files)))
 
-(defun stat (&rest files)
-  (run "stat -r~{ ~A~}" (mapcar #'sh-quote files)))
+(defun stat (options &rest files)
+  (run "stat ~A~{ ~A~}" options (mapcar #'sh-quote files)))
+
+(defun ls (options &rest files)
+  (run "ls ~A~{ ~A~}" options (mapcar #'sh-quote files)))
 
 ;;  Group
 
-(define-resource-class group ()
-  ((passwd :type string)
-   (gid :type fixnum)
-   (members :type list)))
-
-(defmacro define-syntax (name vars regex &body body)
-  (let ((parse-name (intern (format nil "PARSE-~A" (symbol-name name))))
-	(doc (when (stringp (car body)) (pop body)))
-	(values (or (car (last body))
-		    `(values ,@(mapcan (lambda (v) (if (consp v)
-						       (copy-list (cdr v))
-						       (cons v nil)))
-				       vars)))))
-    `(progn
-       (defun ,parse-name (line)
-	 ,@(when doc (list doc))
-	 (cl-ppcre:register-groups-bind ,vars (,regex line)
-	   ,@(or body `(,values))))
-       (defmacro-clause (,name vars IN lines)
-	 ,@(when doc (list doc))
-	 (let ((line (gensym (format nil "~A-LINE-" ,(symbol-name name)))))
-	   `(progn (for ,line in ,lines)
-		   (for (values ,@vars) = (,',parse-name ,line))))))))
+(define-resource-class group () ()
+  ((probe-group-in-/etc/group :properties (name passwd gid members))))
 
 (define-syntax group<5> (name passwd
 			 (#'parse-integer gid)
 			 ((lambda (m) (cl-ppcre:split "," m)) members))
-  "^([^:]*):([^:]*):([^:]*):([^:]*)$"
+  #~|^([^:]*):([^:]*):([^:]*):([^:]*)$|
   "Syntax of the group permissions file /etc/group. See group(5).")
 
-(defmethod gather-resource ((resource group) name)
-  (iter (group<5> (name* passwd* gid* members*) in (grep name "/etc/group"))
-    (when (string= name name*)
-      (with-slots (passwd gid members) resource
-	(setf passwd passwd* gid gid* members members*))
-      (return resource))))
-
-(defun gather-gid-group-name (gid)
-  (iterate (group<5> (name* passwd* gid* members*)
-		      in (grep (format nil ":~A:" gid) "/etc/group"))
-	   (when (= gid gid*)
-	     (return name*))))
+(defmethod probe-group-in-/etc/group ((group group) (os os-unix))
+  (let ((id (resource-id group)))
+    (iter (group<5> (name passwd gid members) in (grep (str id) "/etc/group"))
+	  (when (etypecase id
+		  (integer (= id gid))
+		  (string (string= id name)))
+	    (return (list 'name name
+			  'passwd passwd
+			  'gid gid
+			  'members members))))))
 
 ;;  User
 
 (define-resource-class user ()
-  ((uid :type fixnum)
-   (gid :type fixnum)
-   (groups :type list)
-   (realname :type string)
-   (home :type string)
-   (shell :type string)))
+  ()
+  ((probe-user-in-/etc/passwd :properties (login uid gid realname home shell))
+   (probe-user-groups-in-/etc/group :properties (groups))))
 
 (define-syntax passwd<5> (name pass
 			  (#'parse-integer uid gid)
 			  realname home shell)
-  "^([^:]*):([^:]*):([^:]*):([^:]*):([^:]*):([^:]*):([^:]*)$"
+  #~|^([^:]*):([^:]*):([^:]*):([^:]*):([^:]*):([^:]*):([^:]*)$|
   "Syntax for the password file /etc/passwd. See passwd(5).")
 
-(defun gather-user-groups (user user-gid)
-  (iter (group<5> (name* passwd* gid* members*)
-		  in (grep user "/etc/group"))
-	(with user-group = nil)
-	(cond ((= user-gid gid*) (setq user-group name*))
-	      ((find user members* :test #'string=) (collect name* into groups)))
-	(finally (return (if user-group
-			     (cons user-group groups)
-			     groups)))))
-
-(defmethod gather-resource ((resource user) name)
-  (iter (passwd<5> (name* pass* uid* gid* realname* home* shell*)
-		   in (grep name "/etc/passwd"))
-	(when (string= name name*)
-	  (with-slots (uid gid groups realname home shell) resource
-	    (setf uid uid* gid gid* realname realname* home home* shell shell*
-		  groups (gather-user-groups name gid*)))
-	  (return resource))))
-
-(defun gather-uid-user-name (uid)
-  (iterate (passwd<5> (name* pass* uid* gid* realname* home* shell*)
-		      in (grep (format nil ":~D:" uid) "/etc/passwd"))
-	   (when (= uid uid*)
-	     (return name*))))
-
-;;  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)
-      (:directory         . #o040000)
-      (:block-special     . #o060000)
-      (:file              . #o100000)
-      (:link              . #o120000)
-      (:socket            . #o140000))
-  :test 'equalp)
-
-(defun mode-file-type (mode)
-  (car (rassoc (logand mode #o170000) +file-type-mode-bits+)))
-
-(defun mode-permissions (mode)
-  (let ((s (make-string 9)))
-    (setf (char s 0) (if (logtest     #o0400 mode) #\r #\-))
-    (setf (char s 1) (if (logtest     #o0200 mode) #\w #\-))
-    (setf (char s 2) (if (logtest     #o0100 mode)
-			 (if (logtest #o4000 mode) #\s #\x)
-			 (if (logtest #o4000 mode) #\S #\-)))
-    (setf (char s 3) (if (logtest     #o0040 mode) #\r #\-))
-    (setf (char s 4) (if (logtest     #o0020 mode) #\w #\-))
-    (setf (char s 5) (if (logtest     #o0010 mode)
-			 (if (logtest #o2000 mode) #\s #\x)
-			 (if (logtest #o2000 mode) #\S #\-)))
-    (setf (char s 6) (if (logtest     #o0004 mode) #\r #\-))
-    (setf (char s 7) (if (logtest     #o0002 mode) #\w #\-))
-    (setf (char s 8) (if (logtest     #o0001 mode)
-			 (if (logtest #o1000 mode) #\s #\x)
-			 (if (logtest #o1000 mode) #\S #\-)))
-    s))
-
-(define-syntax stat<1> ((#'sh-parse-integer dev ino mode nlink uid gid
-					    rdev size atime mtime ctime
-					    blksize blocks flags)
-			file)
-  "^([0-9]+) ([0-9]+) ([0-9]+) ([0-9]+) ([0-9]+) ([0-9]+) ([0-9]+) ([0-9]+) ([0-9]+) ([0-9]+) ([0-9]+) ([0-9]+) ([0-9]+) ([0-9]+) (.+)$"
-  "Syntax for raw stat(1) output."
-  (values file dev ino mode nlink uid gid rdev size
-	  atime mtime ctime blksize blocks flags))
-
-(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)))))
-
-(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))
+(defmethod probe-user-in-/etc/passwd ((user user) (os os-unix))
+  (let ((id (resource-id user)))
+    (iter (passwd<5> (login pass uid gid realname home shell)
+		     in (etypecase id
+			  (integer (grep (str #\: id #\:) "/etc/passwd"))
+			  (string (egrep (str #\^ id #\:) "/etc/passwd"))))
+	  (when (etypecase id
+		  (string (string= id login))
+		  (integer (= id uid)))
+	    (return (list 'login login 'uid uid 'gid gid
+			  'realname realname 'home home 'shell shell))))))
+
+(defmethod probe-user-groups-in-/etc/group ((user user) (os os-unix))
+  (let* ((id (resource-id user))
+	 (user-login (if (stringp id)
+			 id
+			 (get-probed user 'login)))
+	 (user-gid (get-probed user 'gid)))
+    (iter (group<5> (name passwd gid members) in (grep user-login
+						       "/etc/group"))
+	  (with user-group = nil)
+	  (cond ((= user-gid gid) (setq user-group name))
+		((find user-login members :test #'string=) (collect name into groups)))
+	  (finally (let ((groups (sort groups #'string<)))
+		     (return (list 'groups (if user-group
+					       (cons user-group groups)
+					       groups))))))))
+
+;;  st_mode, see stat(2)
+
+(define-constant +stat-mode-types+
+    '((fifo              #\p #o010000)
+      (character-special #\c #o020000)
+      (directory         #\d #o040000)
+      (block-special     #\b #o060000)
+      (file              #\- #o100000)
+      (symbolic-link     #\l #o120000)
+      (socket            #\s #o140000))
+  :test #'equal)
+
+(defun mode-string-type (mode-string)
+  (let ((c (char mode-string 0)))
+    (or (car (find c +stat-mode-types+ :key #'second :test #'char=))
+	(error "Unknown mode string type : ~S" c))))
+
+(defun mode-type (mode)
+  (let ((m (logand mode #o170000)))
+    (or (car (find m +stat-mode-types+ :key #'third :test #'=))
+	(error "Unknown mode type : #o~O." m))))
+
+(defun type-mode (type)
+  (or (third (find type +stat-mode-types+ :key #'car :test #'eq))
+      (error "Unknown type ~S." type)))
+
+(defun type-mode-char (type)
+  (or (second (find type +stat-mode-types+ :key #'car :test #'eq))
+      (error "Unknown type ~S." type)))
+
+(defun mode-string (mode)
+  (str (type-mode-char (mode-type mode))
+       (if (logtest     #o0400 mode) #\r #\-)
+       (if (logtest     #o0200 mode) #\w #\-)
+       (if (logtest     #o0100 mode)
+	   (if (logtest #o4000 mode) #\s #\x)
+	   (if (logtest #o4000 mode) #\S #\-))
+       (if (logtest     #o0040 mode) #\r #\-)
+       (if (logtest     #o0020 mode) #\w #\-)
+       (if (logtest     #o0010 mode)
+	   (if (logtest #o2000 mode) #\s #\x)
+	   (if (logtest #o2000 mode) #\S #\-))
+       (if (logtest     #o0004 mode) #\r #\-)
+       (if (logtest     #o0002 mode) #\w #\-)
+       (if (logtest     #o0001 mode)
+	   (if (logtest #o1000 mode) #\s #\x)
+	   (if (logtest #o1000 mode) #\S #\-))))
+
+(defun parse-mode-string (s)
+  (declare (type (string 10) s))
   (logior
    (ecase (char s 0) (#\- 0) (#\r #o0400))
    (ecase (char s 1) (#\- 0) (#\w #o0200))
@@ -230,11 +180,112 @@
    (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)))))
+;;  Filesystem nodes
+
+(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))))
+
+(defun make-one-second-span (time)
+  (let ((y   (chronicity:year-of   time))
+	(m   (chronicity:month-of  time))
+	(d   (chronicity:day-of    time))
+	(h   (chronicity:hour-of   time))
+	(min (chronicity:minute-of time))
+	(sec (chronicity:sec-of    time)))
+    (make-instance 'chronicity:span
+		   :start (chronicity:make-datetime y m d h min sec)
+		   :end   (chronicity:make-datetime y m d h min (1+ sec)))))
+
+(define-syntax ls<1>-lT (mode
+			 (#'sh-parse-integer links)
+			 owner
+			 group
+			 (#'sh-parse-integer size)
+			 (#'chronicity:parse time)
+			 name)
+  #~|^([-a-zA-Z]{10})\s+([0-9]+)\s+(\S+)\s+(\S+)\s+([0-9]+)\s+(\S+ \S+ \S+ \S+)\s+(.+)$|
+  "Syntax for `ls -lT` output. See ls(1)."
+  (values name mode links owner group size time))
+
+(defmethod probe-vnode-using-ls ((vnode vnode) (os os-unix))
+  (let ((id (resource-id vnode)))
+    (iter (ls<1>-lT (name mode links owner group size mtime)
+		    in (ls "-ldT" id))
+	  (when (string= id name)
+	    (return (list 'mode mode
+			  'links links
+			  'owner owner
+			  'group group
+			  'size size
+			  'mtime (make-one-second-span mtime)))))))
+
+(defun parse-unix-timestamp (x)
+  (let ((n (typecase x
+	     (string (parse-integer x))
+	     (integer x))))
+    (local-time:unix-to-timestamp n)))
+
+(define-syntax stat<1>-r ((#'sh-parse-integer
+			   dev ino mode links uid gid rdev size)
+			  (#'parse-unix-timestamp atime mtime ctime)
+			  (#'sh-parse-integer blksize blocks flags)
+			  file)
+    #~|^([0-9]+) ([0-9]+) ([0-9]+) ([0-9]+) ([0-9]+) ([0-9]+) ([0-9]+) ([0-9]+) ([0-9]+) ([0-9]+) ([0-9]+) ([0-9]+) ([0-9]+) ([0-9]+) (.+)$|
+  "Syntax for raw stat(1) output."
+  (values file dev ino mode links uid gid rdev size
+	  atime mtime ctime blksize blocks flags))
+
+(defmethod probe-vnode-using-stat ((vnode vnode) (os os-unix))
+  (let ((id (resource-id vnode)))
+    (iter (stat<1>-r (name dev ino mode links uid gid rdev size
+			   atime mtime ctime blksize blocks flags)
+		     in (stat "-r" id))
+	  (when (string= id name)
+	    (return (list 'dev dev
+			  'ino ino
+			  'mode (mode-string mode)
+			  'links links
+			  'uid uid
+			  'gid gid
+			  'rdev rdev
+			  'size size
+			  'atime atime
+			  'mtime mtime
+			  'ctime ctime
+			  'blksize blksize
+			  'blocks blocks
+			  'flags flags))))))
+
+;;  Regular file
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defvar *cksum-algorithms*
+    '(cksum md4 md5 rmd160 sha1 sha224 sha256 sha384 sha512 sum sysvsum)))
+
+(define-resource-class file (vnode) ()
+  #.(iter (for algorithm in *cksum-algorithms*)
+	  (collect `(,(sym 'probe-file-cksum- algorithm)
+		      :properties (,algorithm)))))
+
+(define-syntax cksum<1> (algo sum file)
+    #~|(\S+) \((.*)\) = (\S+)|
+  "Syntax for cksum(1) output.")
+
+#.(cons 'progn
+	(iter (for algorithm in *cksum-algorithms*)
+	      (for name = (sym 'probe-file-cksum- algorithm))
+	      (collect `(defgeneric ,name (file)))
+	      (collect `(defmethod ,name ((file file))
+			  (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))
+				    (return (list ',algorithm sum)))))))))
+
+(disable-re-syntax)