FranzCross,records-table: add support for publishing tombstones

Bogdanp · Oct 13, 2023 · e7aaec3 · e7aaec3
1 parent fa8e8d4
commit e7aaec3
Show file tree

Hide file tree

Showing 2 changed files with 71 additions and 22 deletions.
diff --git a/FranzCross/mixin.rkt b/FranzCross/mixin.rkt
@@ -5,6 +5,19 @@
          "hacks.rkt")
 
 
+;; combinator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(provide
+ compose-mixins)
+
+(define ((compose-mixins . ms) %)
+  (let loop ([ms ms])
+    ((car ms)
+     (if (pair? (cdr ms))
+         (loop (cdr ms))
+         %))))
+
+
 ;; text ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (provide
@@ -135,9 +148,10 @@
    (window
     #:size '(320 #f)
     (input
-     #:mixin (λ (%)
-               (let ([mix-typeahead (mix-typeahead
-                                     '("cleanup.policy"
-                                       "compression.type"))])
-                 (mix-initial-focus (mix-typeahead %))))
+     #:mixin
+     (compose-mixins
+      (mix-typeahead
+       '("cleanup.policy"
+         "compression.type"))
+      mix-initial-focus)
      ""))))
diff --git a/FranzCross/records-table.rkt b/FranzCross/records-table.rkt
@@ -10,8 +10,10 @@
          racket/list
          racket/match
          racket/vector
+         "alert.rkt"
          "combinator.rkt"
          "common.rkt"
+         "hacks.rkt"
          "mixin.rkt"
          "observable.rkt"
          "preference.rkt"
@@ -123,6 +125,27 @@
           (IteratorResult->original res)))
       (list->vector
        (apply-script script originals id))))
+  (define (do-publish-tombstone r)
+    (when (confirm #:title "Really publish tombstone?"
+                   #:message "This action cannot be undone."
+                   #:action-label "Publish"
+                   #:renderer (get-parent))
+      (call-with-status-proc
+       (lambda (status)
+         (status "Publishing tombstone...")
+         (publish-record
+          topic
+          (IteratorRecord-partition-id r)
+          (IteratorRecord-key r)
+          #f
+          id)))
+      (fetch)))
+  (define (view-record r)
+    (render
+     (record-detail-window
+      #:key-format (topic-config-key-format ^@config)
+      #:val-format (topic-config-val-format ^@config)
+      r topic)))
   (add-hooks
    #:on-create
    (lambda ()
@@ -156,27 +179,39 @@
         (~data k)
         (~data v)))
      #:mixin
-     (λ (%)
-       (class %
-         (inherit get-column-width)
-         (super-new)
-         (set! get-column-widths*
-               (lambda ()
-                 (for/list ([i (in-range 5)])
-                   (define-values (width _min-width _max-width)
-                     (get-column-width i))
-                   (list i width))))))
+     (compose-mixins
+      (λ (%)
+        (class %
+          (inherit get-column-width)
+          (super-new)
+          (set! get-column-widths*
+                (lambda ()
+                  (for/list ([i (in-range 5)])
+                    (define-values (width _min-width _max-width)
+                      (get-column-width i))
+                    (list i width))))))
+      (mix-context-event
+       (lambda (event maybe-index)
+         (when (and maybe-index (not ^@live?))
+           (define r (IteratorResult->record (vector-ref ^@records maybe-index)))
+           (render-popup-menu*
+            (get-parent)
+            (apply
+             popup-menu
+             (menu-item "View" (λ () (view-record r)))
+             (if (IteratorRecord-key r)
+                 (list
+                  (menu-item
+                   "Publish tombstone..."
+                   (λ () (do-publish-tombstone r))))
+                 null))
+            event)))))
      (lambda (event entries selection)
        (case event
          [(dclick)
           (when selection
-            (define r
-              (IteratorResult->record (vector-ref entries selection)))
-            (render
-             (record-detail-window
-              #:key-format (topic-config-key-format ^@config)
-              #:val-format (topic-config-val-format ^@config)
-              r topic)))])))
+            (view-record
+             (IteratorResult->record (vector-ref entries selection))))])))
     (hpanel
      #:stretch '(#t #f)
      (text