Add audit logging.

4 files changed, 104 insertions, 67 deletions

diff --git a/community-garden.scm b/community-garden.scm
index 5c8c383..7cd535a 100644
--- a/community-garden.scm
+++ b/community-garden.scm
@@ -40,35 +40,43 @@
           "Spritely Institute Community Garden"
           (make-garden-bed 8 8)
           the-garden-gate)))
+(define our-garden-community
+  (garden-run
+   (spawn ^garden-community our-garden)))
 (define onion-netlayer (garden-run (new-onion-netlayer)))
 (define mycapn
   (garden-run
    (let* ((mycapn (spawn-mycapn onion-netlayer))
-          (garden-sref ($ mycapn 'register our-garden 'onion)))
-     (format #t "edit-garden Dave ~a\n" (ocapn-id->string garden-sref))
+          (community-sref ($ mycapn 'register our-garden-community 'onion)))
+     (format #t "Connect to: ~a\n" (ocapn-id->string community-sref))
      mycapn)))
 
-(define alice (alice-run (spawn ^gardener "Alice" our-garden)))
-(alice-run ($ alice 'plant 1 1 sunflower/approved))
-(alice-run ($ alice 'plant 2 1 sunflower/approved))
-(alice-run ($ alice 'plant 1 2 sunflower/approved))
-(alice-run ($ alice 'plant 2 2 sunflower/approved))
-(alice-run ($ alice 'plant 5 1 cabbage/approved))
-(alice-run ($ alice 'plant 6 1 cabbage/approved))
-(alice-run ($ alice 'plant 5 2 cabbage/approved))
-(alice-run ($ alice 'plant 6 2 cabbage/approved))
+(define alice
+  (alice-run (<- our-garden-community 'register-gardener "Alice")))
+(define (alice-plant x y plant)
+  (alice-run (on alice
+                 (lambda (alice)
+                   (<- alice 'plant x y plant)))))
+
+(alice-plant 1 1 sunflower/approved)
+(alice-plant 2 1 sunflower/approved)
+(alice-plant 1 2 sunflower/approved)
+(alice-plant 2 2 sunflower/approved)
+(alice-plant 5 1 cabbage/approved)
+(alice-plant 6 1 cabbage/approved)
+(alice-plant 5 2 cabbage/approved)
+(alice-plant 6 2 cabbage/approved)
 
-(define catbird-visitor (catbird-run (spawn ^visitor "Catbird UI" our-garden)))
+(define catbird-visitor
+  (catbird-run (<- our-garden-community 'register-visitor "Catbird Viewer")))
 (define catbird-garden-bed (make-atomic-box #f))
 (define catbird-garden-name (make-atomic-box #f))
 (catbird-run
- (on ($ catbird-visitor 'get-garden-name)
-     (lambda (name)
-       (atomic-box-set! catbird-garden-name name))))
-(catbird-run
- (on ($ catbird-visitor 'inspect-garden)
-     (lambda (garden-bed)
-       (atomic-box-set! catbird-garden-bed garden-bed))))
+ (on catbird-visitor
+     (lambda (visitor)
+       (on (<- visitor 'get-garden-name)
+           (lambda (name)
+             (atomic-box-set! catbird-garden-name name))))))
 
 (run-catbird
  (lambda ()
diff --git a/community-garden/actors.scm b/community-garden/actors.scm
index d98894f..5146047 100644
--- a/community-garden/actors.scm
+++ b/community-garden/actors.scm
@@ -9,7 +9,7 @@
             ^garden-gate
             ^garden
             ^visitor
-            ^gardener))
+            ^garden-community))
 
 (define* (^botanist _bcom)
   (define registry (spawn ^cell '()))
@@ -18,59 +18,70 @@
   (methods
    ((approve-plant plant)
     (let ((sealed-plant ($ seal-plant plant)))
-      ($ registry (cons sealed-plant ($ registry)))
+      ($ registry (cons (list (plant-name plant) sealed-plant)
+                        ($ registry)))
       sealed-plant))
    ((check-plant plant)
     (if ($ approved-plant? plant)
         ($ unseal-plant plant)
         (error "plant is not allowed" plant)))
-   ((approved-plants)
+   ((get-approved-plants)
     ($ registry))))
 
 (define (^garden-gate bcom botanist)
   (methods
    ((check-plant plant)
     ($ botanist 'check-plant plant))
-   ((approved-plants)
-    ($ botanist 'approved-plants))))
+   ((get-approved-plants)
+    ($ botanist 'get-approved-plants))))
 
 (define (^garden bcom name garden-bed garden-gate)
-  (define (ensure-empty x y)
+  (define (ensure-empty name x y)
     (when (garden-bed-ref garden-bed x y)
-      (format #t "tried to plant in occupied tile (~a, ~a)\n" x y)
+      (format #t "~a tried to plant in occupied tile (~a, ~a)\n"
+              name x y)
       (error "tile already has something planted in it" x y)))
   (methods
    ((get-name) name)
    ((get-bed) garden-bed)
    ((get-approved-plants)
-    ($ garden-gate 'approved-plants))
-   ((plant x y sealed-plant)
-    (ensure-empty x y)
+    ($ garden-gate 'get-approved-plants))
+   ((plant gardener-name x y sealed-plant)
+    (ensure-empty gardener-name x y)
     (let* ((plant ($ garden-gate 'check-plant sealed-plant))
            (new-bed (garden-bed-set garden-bed x y plant)))
-      (format #t "planted ~a in tile (~a, ~a)\n" (plant-name plant) x y)
+      (format #t "~a planted ~a in tile (~a, ~a)\n"
+              gardener-name (plant-name plant) x y)
       (bcom (^garden bcom name new-bed garden-gate))))
-   ((dig-up x y)
+   ((dig-up gardener-name x y)
     (let ((new-bed (garden-bed-set garden-bed x y #f)))
-      (format #t "dug up tile (~a, ~a)\n" x y)
+      (format #t "~a dug up tile (~a, ~a)\n" gardener-name x y)
       (bcom (^garden bcom name new-bed garden-gate))))))
 
-(define (^visitor bcom name garden)
-  (methods
-   ((get-name) name)
-   ((get-garden-name)
-    (<- garden 'get-name))
-   ((inspect-garden)
-    (<- garden 'get-bed))))
-
-(define (^gardener bcom name garden)
+(define (^garden-community bcom garden)
+  (define garden-name ($ garden 'get-name))
+  (define (^gardener bcom name)
+    (methods
+     ((get-name) name)
+     ((get-garden-name) garden-name)
+     ((get-approved-plants)
+      ($ garden 'get-approved-plants))
+     ((inspect-garden)
+      ($ garden 'get-bed))
+     ((plant x y plant)
+      ($ garden 'plant name x y plant))
+     ((dig-up x y)
+      ($ garden 'dig-up name x y))))
+  (define (^visitor bcom name)
+    (methods
+     ((get-name) name)
+     ((get-garden-name) garden-name)
+     ((inspect-garden)
+      ($ garden 'get-bed))))
   (methods
-   ((get-name) name)
-   ((get-garden-name)
-    (<- garden 'get-name))
-   ((inspect-garden)
-    (<- garden 'get-bed))
-   ((plant x y plant)
-    (<- garden 'plant x y plant))
-   ((dig-up x y)
-    (<- garden 'dig-up x y))))
+   ((register-gardener name)
+    (format #t "~a has joined ~a\n" name garden-name)
+    (spawn ^gardener name))
+   ((register-visitor name)
+    (format #t "~a has come to visit ~a\n" name garden-name)
+    (spawn ^visitor name))))
diff --git a/community-garden/edit.scm b/community-garden/edit.scm
index 3da54ba..01addd6 100644
--- a/community-garden/edit.scm
+++ b/community-garden/edit.scm
@@ -8,16 +8,24 @@
   #:use-module (ice-9 match)
   #:export (edit-garden))
 
-(define (edit-garden name garden-address)
-  (define garden-sref (string->ocapn-id garden-address))
+(define (edit-garden name community-address)
+  (define community-sref (string->ocapn-id community-address))
   (define vat (spawn-vat))
   (define-vat-run vat-run vat)
   (define onion-netlayer (vat-run (new-onion-netlayer)))
   (define mycapn (vat-run (spawn-mycapn onion-netlayer)))
-  (define garden-vow (vat-run ($ mycapn 'enliven garden-sref)))
-  (define approved-plants-vow (vat-run (<- garden-vow 'get-approved-plants)))
-  (define gardener (vat-run (spawn ^gardener name garden-vow)))
+  (define community-vow (vat-run ($ mycapn 'enliven community-sref)))
+  (define gardener (vat-run (<- community-vow 'register-gardener name)))
+  (define approved-plants-vow (vat-run (<- gardener 'get-approved-plants)))
   (define running? #t)
+  (define (plant-ref plants name)
+    (let loop ((plants plants))
+      (match plants
+        (() #f)
+        (((k v) . rest)
+         (if (string=? k name)
+             v
+             (loop rest))))))
   (define (read*)
     (display "> ")
     (read))
@@ -26,18 +34,26 @@
       (('quit)
        (set! running? #f))
       (('get-garden-name)
-       (vat-run (on ($ gardener 'get-garden-name)
+       (vat-run (on (<- gardener 'get-garden-name)
                     (lambda (name)
-                      (format #t "~a\n" name)))))
+                      (format #t "Garden name: ~a\n"
+                              name)))))
+      (('list-plants)
+       (vat-run
+        (on approved-plants-vow
+            (lambda (plants)
+              (for-each (match-lambda
+                          ((name _)
+                           (format #t "~a\n" name)))
+                        plants)))))
       (('dig-up x y)
        (format #t "dig up tile (~a, ~a)\n" x y)
-       (vat-run ($ gardener 'dig-up x y)))
-      (('plant x y)
+       (vat-run (<- gardener 'dig-up x y)))
+      (('plant x y name)
        (format #t "plant in tile (~a, ~a)\n" x y)
        (vat-run
         (on approved-plants-vow
-            (match-lambda
-              ((plant . _)
-               ($ gardener 'plant x y plant))))))
+            (lambda (plants)
+              (<- gardener 'plant x y (plant-ref plants name))))))
       (exp
        (format #t "unrecognized command: ~a\n" exp)))))
diff --git a/community-garden/view.scm b/community-garden/view.scm
index e43617b..429394a 100644
--- a/community-garden/view.scm
+++ b/community-garden/view.scm
@@ -60,7 +60,7 @@
   (define title
     (make <label>
       #:name 'name
-      #:text (garden-name garden)
+      #:text (or (garden-name garden) "Untitled")
       #:font title-font
       #:position (vec2 32.0 (- %window-height 72.0))))
   (define tile-container
@@ -73,12 +73,14 @@
   (refresh-garden garden)
   (run-script garden
     (forever
-     (sleep 1.0)
      ((vat garden)
       (lambda ()
-        (on ($ (visitor garden) 'inspect-garden)
-            (lambda (garden-bed)
-              (atomic-box-set! (garden-bed-box garden) garden-bed))))))))
+        (on (visitor garden)
+            (lambda (visitor)
+              (on (<- visitor 'inspect-garden)
+                  (lambda (garden-bed)
+                    (atomic-box-set! (garden-bed-box garden) garden-bed)))))))
+     (sleep 0.5))))
 
 (define (for-each-tile proc tiles)
   (vector-for-each