🔧 Show export jobs in the internal debug panel

backend/resources/app/templates/debug.tmpl

@@ -237,5 +237,60 @@ Debug Main Page
       </form>
     </fieldset>
   </section>
+
+</main>
+
+<main class="dashboard wide">
+  <section class="widget wide">
+    <fieldset>
+      <legend>Export jobs:</legend>
+      <desc>
+        Export jobs as the exporter left them in redis. Records expire an hour
+        after the export settles, so this is a live view, not a history.
+      </desc>
+
+      <form method="get" action="/dbg">
+        <div class="row">
+          <input type="text" style="width:300px" name="job-id"
+                 placeholder="filter by job id" value="{{export-job-filter}}" />
+          <input type="submit" value="Filter" />
+          <a href="/dbg">clear</a>
+        </div>
+      </form>
+
+      <div class="scroll-box">
+        <table>
+          <thead>
+            <tr>
+              <th>JOB ID</th>
+              <th>STATE</th>
+              <th>PROGRESS</th>
+              <th>CMD</th>
+              <th>BACKEND</th>
+              <th>NAME</th>
+              <th>CREATED</th>
+              <th>ENDED</th>
+            </tr>
+          </thead>
+          <tbody>
+            {% for job in export-jobs %}
+            <tr>
+              <td><tt>{{job.id}}</tt></td>
+              <td>{{job.state}}{% if job.interrupted %} (interrupted){% endif %}</td>
+              <td>{{job.done}} / {{job.total}}</td>
+              <td>{{job.cmd}}</td>
+              <td>{{job.backend}}</td>
+              <td>{{job.name}}</td>
+              <td>{{job.created-at}}</td>
+              <td>{{job.ended-at}}</td>
+            </tr>
+            {% empty %}
+            <tr><td colspan="8">No export jobs.</td></tr>
+            {% endfor %}
+          </tbody>
+        </table>
+      </div>
+    </fieldset>
+  </section>
 </main>
 {% endblock %}

backend/resources/app/templates/styles.css

@@ -143,6 +143,35 @@ nav > div:not(:last-child) {
   height: fit-content;
 }
 
+/* A widget that holds a table rather than a form: full width, and tall
+   enough to be worth scrolling inside. */
+.dashboard.wide {
+  margin-top: 0px;
+}
+
+.widget.wide {
+  max-width: none;
+  width: 100%;
+}
+
+.widget.wide .scroll-box {
+  max-height: 320px;
+  overflow-y: auto;
+  margin-top: 10px;
+}
+
+.widget.wide table {
+  width: 100%;
+  border-collapse: collapse;
+}
+
+.widget.wide th {
+  text-align: left;
+  position: sticky;
+  top: 0;
+  background: white;
+}
+
 .widget input[type=submit] {
   outline: none;
   border: 1px solid gray;

backend/src/app/http/debug.clj

@@ -22,6 +22,7 @@
    [app.db :as db]
    [app.features.file-migrations :as feat.fmig]
    [app.http.session :as session]
+   [app.redis :as rds]
    [app.rpc.commands.auth :as auth]
    [app.rpc.commands.files-create :refer [create-file]]
    [app.rpc.commands.profile :as profile]
@@ -47,11 +48,53 @@
 ;; INDEX
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+(def ^:private max-export-jobs 200)
+
+(defn- scan-export-job-keys
+  "Note: no index for now, get them all and filter"
+  [conn pattern]
+  (loop [cursor "0"
+         found  []]
+    (let [[cursor keys] (rds/scan conn cursor pattern max-export-jobs)
+          found         (into found keys)]
+      (if (or (nil? cursor)
+              (= "0" cursor)
+              (>= (count found) max-export-jobs))
+        (into [] (take max-export-jobs) found)
+        (recur cursor found)))))
+
+(defn- get-export-jobs
+  [cfg job-id]
+  (let [filtered? (not (str/empty-or-nil? job-id))
+        job-uuid  (when filtered? (parse-uuid job-id))]
+    (if (and filtered? (nil? job-uuid))
+      []
+      (try
+        (let [pattern (str (cf/get :tenant) ".export.job." (or job-uuid "*"))]
+          (->> (rds/run! cfg (fn [{:keys [::rds/conn]}]
+                               (->> (scan-export-job-keys conn pattern)
+                                    (mapv (fn [key] (rds/hget conn key "data"))))))
+               (keep (fn [blob]
+                       (try
+                         (t/decode-str blob)
+                         (catch Throwable _ nil))))
+               (sort-by :created-at #(compare %2 %1))
+               ;; The exporter stores instants as epoch millis.
+               (map (fn [{:keys [created-at ended-at] :as job}]
+                      (-> job
+                          (assoc :created-at (some-> created-at ct/inst (ct/format-inst :rfc1123)))
+                          (assoc :ended-at (some-> ended-at ct/inst (ct/format-inst :rfc1123))))))
+               (vec)))
+        (catch Throwable cause
+          (l/warn :hint "unable to read export jobs" :cause cause)
+          [])))))
+
 (defn index-handler
   [cfg request]
   (let [profile-id (::session/profile-id request)
         offset     (clock/get-offset profile-id)
-        profile    (profile/get-profile cfg profile-id)]
+        profile    (profile/get-profile cfg profile-id)
+        job-filter (some-> request :params :job-id str/trim)]
     {::yres/status  200
      ::yres/headers {"content-type" "text/html"}
      ::yres/body    (-> (io/resource "app/templates/debug.tmpl")
@@ -62,6 +105,8 @@
                                                         (ct/format-duration offset)
                                                         "NO OFFSET")
                                       :current-time  (ct/format-inst (ct/now) :http)
+                                      :export-jobs (get-export-jobs cfg job-filter)
+                                      :export-job-filter job-filter
                                       :supported-features cfeat/supported-features}))}))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

backend/src/app/main.clj

@@ -283,6 +283,7 @@
 
    ::http.debug/routes
    {::db/pool         (ig/ref ::db/pool)
+    ::rds/pool        (ig/ref ::rds/pool)
     ::session/manager (ig/ref ::session/manager)
     ::sto/storage     (ig/ref ::sto/storage)
     ::setup/props     (ig/ref ::setup/props)}

backend/src/app/redis.clj

@@ -29,6 +29,7 @@
    io.lettuce.core.api.sync.RedisScriptingCommands
    io.lettuce.core.codec.RedisCodec
    io.lettuce.core.codec.StringCodec
+   io.lettuce.core.KeyScanCursor
    io.lettuce.core.KeyValue
    io.lettuce.core.pubsub.api.sync.RedisPubSubCommands
    io.lettuce.core.pubsub.RedisPubSubListener
@@ -40,6 +41,8 @@
    io.lettuce.core.RedisURI
    io.lettuce.core.resource.ClientResources
    io.lettuce.core.resource.DefaultClientResources
+   io.lettuce.core.ScanArgs
+   io.lettuce.core.ScanCursor
    io.lettuce.core.ScriptOutputType
    io.lettuce.core.SetArgs
    io.netty.channel.nio.NioEventLoopGroup
@@ -71,6 +74,8 @@
   (-blpop [_ timeout keys])
   (-eval [_ script])
   (-get [_ key])
+  (-scan [_ cursor pattern limit])
+  (-hget [_ key field])
   (-set [_ key val args])
   (-del [_ key-or-keys])
   (-ping [_]))
@@ -205,6 +210,20 @@
     (assert (string? key) "key expected to be string")
     (.get cmd ^String key))
 
+  (-scan [_ cursor pattern limit]
+    (let [args   (-> (ScanArgs.)
+                     (.match ^String pattern)
+                     (.limit (long limit)))
+          result (.scan cmd
+                        ^ScanCursor (ScanCursor/of ^String cursor)
+                        ^ScanArgs args)]
+      (MapEntry/create
+       (.getCursor ^KeyScanCursor result)
+       (vec (.getKeys ^KeyScanCursor result)))))
+
+  (-hget [_ key field]
+    (.hget cmd ^String key ^String field))
+
   (-set [_ key val args]
     (.set cmd
           ^String key
@@ -345,6 +364,26 @@
       (l/err :hint "timeout on get redis key" :key key :cause cause)
       nil)))
 
+(defn scan
+  [conn cursor pattern limit]
+  (assert (string? cursor) "cursor must be string instance")
+  (assert (string? pattern) "pattern must be string instance")
+  (try
+    (-scan conn cursor pattern limit)
+    (catch RedisCommandTimeoutException cause
+      (l/err :hint "timeout on scan" :pattern pattern :cause cause)
+      nil)))
+
+(defn hget
+  [conn key field]
+  (assert (string? key) "key must be string instance")
+  (assert (string? field) "field must be string instance")
+  (try
+    (-hget conn key field)
+    (catch RedisCommandTimeoutException cause
+      (l/err :hint "timeout on hget" :key key :cause cause)
+      nil)))
+
 (defn set
   ([conn key val]
    (set conn key val nil))