penpot/frontend/src/app/util/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) UXBOX Labs SL

(ns app.util.router
  (:refer-clojure :exclude [resolve])
  (:require
   [app.common.uri :as u]
   [app.config :as cfg]
   [app.util.browser-history :as bhistory]
   [app.util.dom :as dom]
   [app.util.timers :as ts]
   [beicon.core :as rx]
   [goog.events :as e]
   [potok.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 path-params] (resolve router id path-params {}))
  ([router id path-params query-params]
   (when-let [match (r/match-by-name router id path-params)]
     (r/match->path match query-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 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]
  (ptk/reify ::navigated
    IDeref
    (-deref [_] match)

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

(defn navigate*
  [id path-params query-params replace]
  (ptk/reify ::navigate
    IDeref
    (-deref [_]
      {:id id
       :path-params path-params
       :query-params query-params
       :replace replace})

    ptk/EffectEvent
    (effect [_ state _]
      (let [router  (:router state)
            history (:history state)
            path    (resolve router id path-params query-params)]
        (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] (nav id nil nil))
  ([id path-params] (nav id path-params nil))
  ([id path-params query-params] (navigate* id path-params query-params false)))

(defn nav'
  ([id] (nav id nil nil))
  ([id path-params] (nav id path-params nil))
  ([id path-params query-params] (navigate* id path-params query-params true)))

(def navigate nav)

(defn nav-new-window*
  [{:keys [rname path-params query-params name]}]
  (ptk/reify ::nav-new-window
    ptk/EffectEvent
    (effect [_ state _]
      (let [router (:router state)
            path   (resolve router rname path-params query-params)
            name   (or name "_blank")
            uri    (-> (u/uri cfg/public-uri)
                       (assoc :fragment path))]
        (dom/open-new-window uri name nil)))))

(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))))

;; --- History API

(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 [stoper  (rx/filter (ptk/type? ::initialize-history) stream)
            history (:history state)
            router  (:router state)]
        (ts/schedule #(on-change router (.getToken ^js history)))
        (->> (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/take-until stoper)
              (rx/subs #(on-change router %)))))))