logseq/src/main/frontend/handler/whiteboard.cljs

(ns frontend.handler.whiteboard
  "Whiteboard related handlers"
  (:require [datascript.core :as d]
            [dommy.core :as dom]
            [frontend.db :as db]
            [frontend.db.model :as model]
            [frontend.db.utils :as db-utils]
            [frontend.handler.editor :as editor-handler]
            [frontend.handler.route :as route-handler]
            [frontend.modules.editor.undo-redo :as history]
            [frontend.modules.outliner.core :as outliner]
            [frontend.modules.outliner.file :as outliner-file]
            [frontend.state :as state]
            [frontend.util :as util]
            [logseq.graph-parser.util :as gp-util]
            [logseq.graph-parser.whiteboard :as gp-whiteboard]
            [promesa.core :as p]
            [goog.object :as gobj]
            [clojure.set :as set]
            [clojure.string :as string]
            [cljs-bean.core :as bean]))

(defn js->clj-keywordize
  [obj]
  (js->clj obj :keywordize-keys true))

(defn shape->block [shape page-name]
  (let [properties {:ls-type :whiteboard-shape
                    :logseq.tldraw.shape shape}
        block {:block/page {:block/name (util/page-name-sanity-lc page-name)}
               :block/parent {:block/name page-name}
               :block/properties properties}
        additional-props (gp-whiteboard/with-whiteboard-block-props block page-name)]
    (merge block additional-props)))

(defn- get-whiteboard-clj [page-name]
  (when (model/page-exists? page-name)
    (let [page-block (model/get-page page-name)
          ;; fixme: can we use cache?
          blocks (model/get-page-blocks-no-cache page-name)]
      [page-block blocks])))

(defn- build-shapes
  [page-block blocks]
  (let [shapes-index (get-in page-block [:block/properties :logseq.tldraw.page :shapes-index])
        shape-id->index (zipmap shapes-index (range 0 (count shapes-index)))]
    (->> blocks
         (map (fn [block]
                (assoc block :index (get shape-id->index (str (:block/uuid block)) 0))))
         (sort-by :index)
         (filter gp-whiteboard/shape-block?)
         (map gp-whiteboard/block->shape))))

(defn- whiteboard-clj->tldr [page-block blocks]
  (let [id (str (:block/uuid page-block))
        shapes (build-shapes page-block blocks)
        tldr-page (gp-whiteboard/page-block->tldr-page page-block)
        assets (:assets tldr-page)
        tldr-page (dissoc tldr-page :assets)]
    (clj->js {:currentPageId id
              :assets (or assets #js[])
              :selectedIds #js[]
              :pages [(merge tldr-page
                             {:id id
                              :name (:block/name page-block)
                              :shapes shapes})]})))

(defn build-page-block
  [page-name tldraw-page assets shapes-index]
  (let [page-entity (model/get-page page-name)
        get-k #(gobj/get tldraw-page %)]
    {:block/name page-name
     :block/type "whiteboard"
     :block/properties {:ls-type :whiteboard-page
                        :logseq.tldraw.page {:id (get-k "id")
                                             :name (get-k "name")
                                             :bindings (js->clj-keywordize (get-k "bindings"))
                                             :nonce (get-k "nonce")
                                             :assets (js->clj-keywordize assets)
                                             :shapes-index shapes-index}}
     :block/updated-at (util/time-ms)
     :block/created-at (or (:block/created-at page-entity)
                           (util/time-ms))}))

(defn- compute-tx
  [^js app ^js tl-page new-id-nonces db-id-nonces page-name replace?]
  (let [assets (js->clj-keywordize (.getCleanUpAssets app))
        new-shapes (.-shapes tl-page)
        shapes-index (map #(gobj/get % "id") new-shapes)
        upsert-shapes (->> (set/difference new-id-nonces db-id-nonces)
                           (map (fn [{:keys [id]}]
                                  (-> (.-serialized ^js (.getShapeById tl-page id))
                                      js->clj-keywordize)))
                           (set))
        old-ids (set (map :id db-id-nonces))
        new-ids (set (map :id new-id-nonces))
        created-ids (->> (set/difference new-ids old-ids)
                         (remove string/blank?)
                         (set))
        created-shapes (set (filter #(created-ids (:id %)) upsert-shapes))
        deleted-ids (->> (set/difference old-ids new-ids)
                         (remove string/blank?))
        repo (state/get-current-repo)
        deleted-shapes (when (seq deleted-ids)
                         (->> (db/pull-many repo '[*] (mapv (fn [id] [:block/uuid (uuid id)]) deleted-ids))
                              (map (fn [b]
                                     (get-in b [:block/properties :logseq.tldraw.shape])))))
        deleted-shapes-tx (mapv (fn [id] [:db/retractEntity [:block/uuid (uuid id)]]) deleted-ids)
        with-timestamps (fn [block]
                          (if (contains? created-ids (str (:block/uuid block)))
                            (assoc block :block/updated-at (util/time-ms))
                            (outliner/block-with-timestamps block)))
        changed-shapes (set/difference upsert-shapes created-shapes)
        prev-changed-blocks (when (seq changed-shapes)
                              (db/pull-many repo '[*] (mapv (fn [shape]
                                                              [:block/uuid (uuid (:id shape))]) changed-shapes)))]
    {:page-block (build-page-block page-name tl-page assets shapes-index)
     :upserted-blocks (->> upsert-shapes
                           (map #(shape->block % page-name))
                           (map with-timestamps))
     :delete-blocks deleted-shapes-tx
     :metadata {:whiteboard/transact? true
                :replace? replace?
                :data {:page-name page-name
                       :deleted-shapes deleted-shapes
                       :new-shapes created-shapes
                       :changed-shapes changed-shapes
                       :prev-changed-blocks prev-changed-blocks}}}))

(defonce *last-shapes-nonce (atom {}))
(defn transact-tldr-delta! [page-name ^js app replace?]
  (let [tl-page ^js (second (first (.-pages app)))
        shapes (.-shapes ^js tl-page)
        new-id-nonces (set (map (fn [shape]
                                  {:id (.-id shape)
                                   :nonce (.-nonce shape)}) shapes))
        repo (state/get-current-repo)
        db-id-nonces (or
                      (get-in @*last-shapes-nonce [repo page-name])
                      (set (->> (model/get-whiteboard-id-nonces repo page-name)
                                (map #(update % :id str)))))
        {:keys [page-block upserted-blocks delete-blocks metadata]}
        (compute-tx app tl-page new-id-nonces db-id-nonces page-name replace?)
        tx-data (concat delete-blocks [page-block] upserted-blocks)
        new-shapes (get-in metadata [:data :new-shapes])
        metadata' (cond
                    ;; group
                    (some #(= "group" (:type %)) new-shapes)
                    (assoc metadata :whiteboard/op :group)

                    ;; ungroup
                    (some #(= "group" (:type %)) (get-in metadata [:data :deleted-shapes]))
                    (assoc metadata :whiteboard/op :un-group)

                    ;; arrow
                    (some #(and (= "line" (:type %))
                                (= "arrow "(:end (:decorations %)))) new-shapes)

                    (assoc metadata :whiteboard/op :new-arrow)
                    :else
                    metadata)
        metadata' (if (seq (concat upserted-blocks delete-blocks))
                    metadata'
                    (assoc metadata :undo? true))]
    (swap! *last-shapes-nonce assoc-in [repo page-name] new-id-nonces)
    (if (contains? #{:new-arrow} (:whiteboard/op metadata'))
      (state/set-state! :whiteboard/pending-tx-data
                        {:tx-data tx-data
                         :metadata metadata'})
      (let [pending-tx-data (:whiteboard/pending-tx-data @state/state)
            tx-data' (concat (:tx-data pending-tx-data) tx-data)
            metadata'' (merge metadata' (:metadata pending-tx-data))]
        (state/set-state! :whiteboard/pending-tx-data {})
        (db-utils/transact! repo tx-data' metadata'')))))

(defn get-default-new-whiteboard-tx
  [page-name id]
  [#:block{:name page-name,
           :type "whiteboard",
           :properties
           {:ls-type :whiteboard-page,
            :logseq.tldraw.page
            {:id id,
             :name page-name,
             :ls-type :whiteboard-page,
             :bindings {},
             :nonce 1,
             :assets []}},
           :updated-at (util/time-ms),
           :created-at (util/time-ms)}])

(defn get-whiteboard-entity [page-name]
  (db-utils/entity [:block/name (util/page-name-sanity-lc page-name)]))

(defn create-new-whiteboard-page!
  ([]
   (create-new-whiteboard-page! nil))
  ([name]
   (let [uuid (or (and name (parse-uuid name)) (d/squuid))
         name (or name (str uuid))]
     (db/transact! (get-default-new-whiteboard-tx name (str uuid)))
     (let [entity (get-whiteboard-entity name)
           tx (assoc (select-keys entity [:db/id])
                     :block/uuid uuid)]
       (db-utils/transact! [tx])
       (let [page-entity (get-whiteboard-entity name)]
         (when (and page-entity (nil? (:block/file page-entity)))
           (outliner-file/sync-to-file page-entity)))))))

(defn create-new-whiteboard-and-redirect!
  ([]
   (create-new-whiteboard-and-redirect! (str (d/squuid))))
  ([name]
   (create-new-whiteboard-page! name)
   (route-handler/redirect-to-whiteboard! name)))

(defn ->logseq-portal-shape
  [block-id point]
  {:blockType (if (parse-uuid (str block-id)) "B" "P")
   :id (str (d/squuid))
   :compact false
   :pageId (str block-id)
   :point point
   :size [400, 0]
   :type "logseq-portal"})

(defn add-new-block-portal-shape!
  "Given the block uuid, add a new shape to the referenced block.
   By default it will be placed next to the given shape id"
  [block-uuid source-shape & {:keys [link? bottom?]}]
  (when-let [app (state/active-tldraw-app)]
    (let [^js api (.-api app)
          point (-> (.getShapeById app source-shape)
                    (.-bounds)
                    ((fn [bounds] (if bottom?
                                    [(.-minX bounds) (+ 64 (.-maxY bounds))]
                                    [(+ 64 (.-maxX bounds)) (.-minY bounds)]))))
          shape (->logseq-portal-shape block-uuid point)]
      (when (uuid? block-uuid) (editor-handler/set-blocks-id! [block-uuid]))
      (.createShapes api (clj->js shape))
      (when link?
        (.createNewLineBinding api source-shape (:id shape))))))

(defn page-name->tldr!
  ([page-name]
   (clj->js
    (if page-name
      (if-let [[page-block blocks] (get-whiteboard-clj page-name)]
        (whiteboard-clj->tldr page-block blocks)
        (create-new-whiteboard-page! page-name))
      (create-new-whiteboard-page! nil)))))

(defn- get-whiteboard-blocks
  "Given a page, return all the logseq blocks (exclude all shapes)"
  [page-name]
  (let [blocks (model/get-page-blocks-no-cache page-name)]
    (remove gp-whiteboard/shape-block? blocks)))

(defn- get-last-root-block
  "Get the last root Logseq block in the page. Main purpose is to calculate the new :block/left id"
  [page-name]
  (let [page-id (:db/id (model/get-page page-name))
        blocks (get-whiteboard-blocks page-name)
        root-blocks (filter (fn [block] (= page-id (:db/id (:block/parent block)))) blocks)
        root-block-left-ids (->> root-blocks
                                 (map (fn [block] (get-in block [:block/left :db/id] nil)))
                                 (remove nil?)
                                 (set))
        blocks-with-no-next (remove #(root-block-left-ids (:db/id %)) root-blocks)]
    (when (seq blocks-with-no-next) (first blocks-with-no-next))))

(defn add-new-block!
  [page-name content]
  (let [uuid (d/squuid)
        page-entity (model/get-page page-name)
        last-root-block (or (get-last-root-block page-name) page-entity)
        tx {:block/left (select-keys last-root-block [:db/id])
            :block/uuid uuid
            :block/content (or content "")
            :block/format :markdown ;; fixme to support org?
            :block/page {:block/name (util/page-name-sanity-lc page-name)}
            :block/parent {:block/name page-name}}]
    (db-utils/transact! [tx])
    uuid))

(defn inside-portal?
  [target]
  (some? (dom/closest target ".tl-logseq-cp-container")))

(defn closest-shape
  [target]
  (when-let [shape-el (dom/closest target "[data-shape-id]")]
    (.getAttribute shape-el "data-shape-id")))

(defn get-onboard-whiteboard-edn
  []
  (p/let [^js res (js/fetch "./whiteboard/onboarding.edn") ;; do we need to cache it?
          text (.text res)
          edn (gp-util/safe-read-string text)]
    edn))

(defn clone-whiteboard-from-edn
  "Given a tldr, clone the whiteboard page into current active whiteboard"
  ([edn]
   (when-let [app (state/active-tldraw-app)]
     (clone-whiteboard-from-edn edn (.-api app))))
  ([{:keys [pages blocks]} api]
   (let [page-block (first pages)
         ;; FIXME: should also clone normal blocks
         shapes (build-shapes page-block blocks)
         tldr-page (gp-whiteboard/page-block->tldr-page page-block)
         assets (:assets tldr-page)
         bindings (:bindings tldr-page)]
     (.cloneShapesIntoCurrentPage ^js api (clj->js {:shapes shapes
                                                    :assets assets
                                                    :bindings bindings})))))
(defn should-populate-onboarding-whiteboard?
  "When there is not whiteboard, or there is only whiteboard that is the given page name, we should populate the onboarding whiteboard"
  [page-name]
  (let [whiteboards (model/get-all-whiteboards (state/get-current-repo))]
    (and (or (empty? whiteboards)
             (and
              (= 1 (count whiteboards))
              (= page-name (:block/name (first whiteboards)))))
         (not (state/get-onboarding-whiteboard?)))))

(defn populate-onboarding-whiteboard
  [api]
  (when (some? api)
    (-> (p/let [edn (get-onboard-whiteboard-edn)]
          (clone-whiteboard-from-edn edn api)
          (state/set-onboarding-whiteboard! true))
        (p/catch
         (fn [e] (js/console.warn "Failed to populate onboarding whiteboard" e))))))

(defn- delete-shapes!
  [^js api shapes]
  (apply (.-deleteShapes api) (map :id shapes)))

(defn- create-shapes!
  [^js api shapes]
  (apply (.-createShapes api) (bean/->js shapes)))

(defn- update-shapes!
  [^js api shapes]
  (apply (.-updateShapes api) (bean/->js shapes)))

(defn- select-shapes
  [^js api ids]
  (apply (.-selectShapes api) ids))

(defn update-bindings!
  [^js tl-page page-name]
  (when-let [page (db/entity [:block/name page-name])]
    (let [bindings (get-in page [:block/properties :logseq.tldraw.page :bindings])]
      (when (seq bindings)
        (.updateBindings tl-page (bean/->js bindings))))))

(defn undo!
  [{:keys [tx-meta]}]
  (history/pause-listener!)
  (try
    (when-let [app (state/active-tldraw-app)]
      (let [{:keys [deleted-shapes new-shapes changed-shapes prev-changed-blocks]} (:data tx-meta)
            whiteboard-op (:whiteboard/op tx-meta)
            ^js api (.-api app)]
        (when api
          (case whiteboard-op
            :group
            (do
              (select-shapes api (map :id new-shapes))
              (.unGroup api))
            :un-group
            (do
              (select-shapes api (mapcat :children deleted-shapes))
              (.doGroup api))
            (do
              (when (seq deleted-shapes)
                (create-shapes! api deleted-shapes))
              (when (seq new-shapes)
                (delete-shapes! api new-shapes))
              (when (seq changed-shapes)
                (let [prev-shapes (map (fn [b] (get-in b [:block/properties :logseq.tldraw.shape]))
                                    prev-changed-blocks)]
                  (update-shapes! api prev-shapes))))))))
    (catch :default e
      (js/console.error e)))
  (history/resume-listener!))

(defn redo!
  [{:keys [tx-meta]}]
  (history/pause-listener!)
  (try
    (when-let [app (state/active-tldraw-app)]
      (let [{:keys [page-name deleted-shapes new-shapes changed-shapes]} (:data tx-meta)
            whiteboard-op (:whiteboard/op tx-meta)
            ^js api (.-api app)
            tl-page ^js (second (first (.-pages app)))]
        (when api
          (update-bindings! tl-page page-name)
          (case whiteboard-op
            :group
            (do
              (select-shapes api (mapcat :children new-shapes))
              (.doGroup api))
            :un-group
            (do
              (select-shapes api (map :id deleted-shapes))
              (.unGroup api))
            (do
              (when (seq deleted-shapes)
                (delete-shapes! api deleted-shapes))
              (when (seq new-shapes)
                (create-shapes! api new-shapes))
              (when (seq changed-shapes)
                (update-shapes! api changed-shapes)))))))
    (catch :default e
      (js/console.error e)))
  (history/resume-listener!))