add shift function

lgessler · Apr 12, 2024 · e73f266 · e73f266
1 parent 4d4d00e
commit e73f266
Show file tree

Hide file tree

Showing 2 changed files with 45 additions and 3 deletions.
diff --git a/src/main/glam/models/relation_layer.cljc b/src/main/glam/models/relation_layer.cljc
@@ -43,7 +43,6 @@
 
 ;; admin --------------------------------------------------------------------------------
 ;;
-
 #?(:clj
    (pc/defmutation create-relation-layer [{:keys [node]} {delta :delta [_ temp-id] :ident [_ parent-id] :parent-ident :as params}]
      {::pc/transform ma/admin-required
@@ -88,4 +87,24 @@
            (server-message (str "Relation layer " name " deleted")))))))
 
 #?(:clj
-   (def relation-layer-resolvers [get-relation-layer get-relations create-relation-layer save-relation-layer delete-relation-layer]))
+   (pc/defmutation shift-relation-layer [{:keys [node]} {id :id up? :up?}]
+     {::pc/transform ma/admin-required}
+     (cond
+       (nil? (:relation-layer/id (gxe/entity node id)))
+       (server-error 404 (str "Relation layer not found by ID " id))
+
+       (not (boolean? up?))
+       (server-error 400 (str "Param up? must be a boolean."))
+
+       :else
+       (let [name (:relation-layer/name (gxe/entity node id))
+             parent-id (rl/parent-id node id)
+             tx (sl/shift-relation-layer** node parent-id id up?)
+             success (gxe/submit! node tx)]
+         (if-not success
+           (server-error 500 (str "Failed to shift relation layer " name ". Please try again."))
+           (server-message (str "Relation layer " name " shifted " (if up? "up" "down") ".")))))))
+
+#?(:clj
+   (def relation-layer-resolvers [get-relation-layer get-relations create-relation-layer save-relation-layer
+                                  delete-relation-layer shift-relation-layer]))
diff --git a/src/main/glam/xtdb/span_layer.clj b/src/main/glam/xtdb/span_layer.clj
@@ -1,5 +1,6 @@
 (ns glam.xtdb.span-layer
-  (:require [xtdb.api :as xt]
+  (:require [glam.common :as gc]
+            [xtdb.api :as xt]
             [glam.xtdb.easy :as gxe]
             [glam.xtdb.common :as gxc]
             [glam.xtdb.relation-layer :as rl])
@@ -41,6 +42,28 @@
   [node eid m]
   (gxe/merge node eid (select-keys m [:span-layer/name])))
 
+(gxe/deftx shift-relation-layer [node span-layer-id relation-layer-id up?]
+  ;; Shift a relation layer up or down in its token layer. Attempting to shift beyond either edge will result in a no-op.
+  (let [sl (gxe/entity node span-layer-id)
+        rl (gxe/entity node relation-layer-id)
+        rls (:span-layer/relation-layers sl)]
+    (cond
+      (nil? sl)
+      (throw (ex-info "Span layer does not exist" {:id span-layer-id}))
+
+      (nil? rl)
+      (throw (ex-info "No span layer found for relation layer" {:span-layer span-layer-id
+                                                                :relation-layer  relation-layer-id}))
+
+      (not (some #{relation-layer-id} rls))
+      (throw (ex-info "Span layer is not linked to relation layer" {:span-layer span-layer-id
+                                                                    :relation-layer  relation-layer-id}))
+
+      :else
+      (let [new-tl (assoc sl :span-layer/relation-layers (gc/shift rls relation-layer-id up?))]
+        [(gxe/put* new-tl)]))))
+
+
 (gxe/deftx delete [node eid]
   (let [parent-layer (parent-id node eid)
         unlink (glam.xtdb.token-layer/remove-span-layer** node parent-layer eid)