penpot/frontend/src/app/main/router.cljs

;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS INC

(ns app.main.router
  (:refer-clojure :exclude [resolve])
  (:require
   [app.common.data.macros :as dm]
   [app.common.uri :as u]
   [app.config :as cf]
   [app.main.data.event :as ev]
   [app.util.browser-history :as bhistory]
   [app.util.dom :as dom]
   [app.util.globals :as globals]
   [app.util.timers :as ts]
   [beicon.v2.core :as rx]
   [cuerdas.core :as str]
   [goog.events :as e]
   [potok.v2.core :as ptk]
   [reitit.core :as r]))

;; --- Router API

(defn map->Match
  [data]
  (r/map->Match data))

(defn resolve
  ([router id]
   (resolve router id {}))
  ([router id params]
   (when router
     (when-let [match (r/match-by-name router id)]
       (r/match->path match params)))))

(defn create
  [routes]
  (r/router routes))

(defn initialize-router
  [routes]
  (ptk/reify ::initialize-router
    ptk/UpdateEvent
    (update [_ state]
      (assoc state :router (create routes)))))

(defn encode-url
  [url]
  (js/encodeURIComponent url))

(defn match
  "Given routing tree and current path, return match with possibly
  coerced parameters. Return nil if no match found."
  [router path]
  (let [uri (u/uri path)]
    (when-let [match (r/match-by-path router (:path uri))]
      (let [query-params (u/query-string->map (:query uri))
            params       {:path (:path-params match)
                          :query query-params}]
        (-> match
            (assoc :params params)
            (assoc :query-params query-params))))))

;; --- Navigate (Event)

(defn navigated
  [match send-event-info?]
  (ptk/reify ::navigated
    IDeref
    (-deref [_] match)

    ptk/WatchEvent
    (watch [_ _ _]
      (when send-event-info?
        (let [route  (dm/get-in match [:data :name])
              params (get match :query-params)]
          (rx/of (ptk/event
                  ::ev/event
                  (assoc params
                         ::ev/name "navigate"
                         :route (name route)))))))

    ptk/UpdateEvent
    (update [_ state]
      (-> state
          (assoc :route match)
          (dissoc :exception)))))

(defn navigate
  [id params & {:keys [::replace ::new-window] :as options}]
  (ptk/reify ::navigate
    IDeref
    (-deref [_]
      {:id id
       :params params
       :options options})

    ptk/EffectEvent
    (effect [_ state _]
      (let [router  (:router state)
            history (:history state)
            path    (resolve router id params)]

        (if ^boolean new-window
          (let [name   (or (::window-name options) "_blank")
                uri    (assoc cf/public-uri :fragment path)]
            (dom/open-new-window uri name nil))
          (ts/asap
           #(if ^boolean replace
              (bhistory/replace-token! history path)
              (bhistory/set-token! history path))))))))

(defn assign-exception
  [error]
  (ptk/reify ::assign-exception
    ptk/UpdateEvent
    (update [_ state]
      (if (nil? error)
        (dissoc state :exception)
        (assoc state :exception error)))))

(defn nav
  ([id] (navigate id nil))
  ([id params] (navigate id params))
  ([id params & {:as options}]
   (navigate id params options)))

(defn lookup-name
  [state]
  (dm/get-in state [:route :data :name]))

;; FIXME: rename to lookup-params
(defn get-params
  [state]
  (dm/get-in state [:route :params :query]))

(defn nav-back
  []
  (ptk/reify ::nav-back
    ptk/EffectEvent
    (effect [_ _ _]
      (ts/asap dom/browser-back))))

(defn nav-back-local
  "Navigate back only if the previous page is in penpot app."
  []
  (let [location (.-location js/document)
        referrer (u/uri (.-referrer js/document))]
    (when (or (nil? (:host referrer))
              (= (.-hostname location) (:host referrer)))
      (nav-back))))

(defn nav-root
  "Navigate to the root page."
  []
  (ptk/reify ::nav-root
    ptk/EffectEvent
    (effect [_ _ _]
      (set! (.-href globals/location) "/"))))

(defn reload
  [force?]
  (ptk/reify ::reload
    ptk/EffectEvent
    (effect [_ _ _]
      (ts/asap (partial dom/reload-current-window force?)))))

(defn nav-raw
  [& {:keys [href uri]}]
  (ptk/reify ::nav-raw
    ptk/EffectEvent
    (effect [_ _ _]
      (cond
        (string? uri)
        (.replace globals/location uri)

        (string? href)
        (set! (.-href globals/location) href)))))

(defn get-current-href
  []
  (.-href globals/location))

(defn get-current-path
  []
  (let [hash (.-hash globals/location)]
    (if (str/starts-with? hash "#")
      (subs hash 1)
      hash)))


;; --- History API

;; Check the urls to see if we need to send the navigated event.
;; If two paths are the same we only send the event when there is a
;; change in the parameters `file-id`, `page-id` or `team-id`
(defn- send-event-info?
  [old-url new-url]
  (let [params [:file-id :page-id :team-id]
        new-uri (u/uri new-url)
        new-path (:path new-uri)
        new-params (-> new-uri :query u/query-string->map (select-keys params))
        old-uri (u/uri old-url)
        old-path (:path old-uri)
        old-params (-> old-uri :query u/query-string->map (select-keys params))]
    (or (not= old-path new-path)
        (not= new-params old-params))))

(defn initialize-history
  [on-change]
  (ptk/reify ::initialize-history
    ptk/UpdateEvent
    (update [_ state]
      (let [history (bhistory/create)]
        (bhistory/enable! history)
        (assoc state :history history)))

    ptk/EffectEvent
    (effect [_ state stream]
      (let [stopper (rx/filter (ptk/type? ::initialize-history) stream)
            history (:history state)
            router  (:router state)]
        (ts/schedule #(on-change router (.getToken ^js history) true))
        (->> (rx/concat
              (rx/of nil nil)
              (rx/create
               (fn [subs]
                 (let [key (e/listen history "navigate" (fn [o] (rx/push! subs (.-token ^js o))))]
                   (fn []
                     (bhistory/disable! history)
                     (e/unlistenByKey key))))))
             (rx/buffer 2 1)
             (rx/take-until stopper)
             (rx/subs!
              (fn [[old-url new-url]]
                (when (some? new-url)
                  (let [send? (or (nil? old-url) (send-event-info? old-url new-url))]
                    (on-change router new-url send?))))))))))