WIP

common/src/app/common/fressian.clj

@@ -118,6 +118,36 @@
             (d/ordered-map)
             (partition-all 2 (seq kvs)))))
 
+
+(defn- adapt-write-handler
+  [{:keys [name class wfn]}]
+  [class {name (reify WriteHandler
+                 (write [_ w o]
+                   (wfn name w o)))}])
+
+(defn- adapt-read-handler
+  [{:keys [name rfn]}]
+  [name (reify ReadHandler
+          (read [_ rdr _ _]
+            (rfn rdr)))])
+
+(defn- merge-handlers
+  [m1 m2]
+  (-> (merge m1 m2)
+      (d/without-nils)))
+
+(def ^:private
+  xf:adapt-write-handler
+  (comp
+   (filter :wfn)
+   (map adapt-write-handler)))
+
+(def ^:private
+  xf:adapt-read-handler
+  (comp
+   (filter :rfn)
+   (map adapt-read-handler)))
+
 (def ^:dynamic *write-handler-lookup* nil)
 (def ^:dynamic *read-handler-lookup* nil)
 
@@ -126,36 +156,39 @@
 
 (defn add-handlers!
   [& handlers]
-  (letfn [(adapt-write-handler [{:keys [name class wfn]}]
+  (let [write-handlers'
-            [class {name (reify WriteHandler
+        (into {} xf:adapt-write-handler handlers)
-                           (write [_ w o]
-                             (wfn name w o)))}])
 
-          (adapt-read-handler [{:keys [name rfn]}]
+        read-handlers'
-            [name (reify ReadHandler
+        (into {} xf:adapt-read-handler handlers)
-                    (read [_ rdr _ _]
-                      (rfn rdr)))])
 
-          (merge-and-clean [m1 m2]
+        write-handlers'
-            (-> (merge m1 m2)
+        (swap! write-handlers merge-handlers write-handlers')
-                (d/without-nils)))]
 
-    (let [whs (into {}
+        read-handlers'
-                    (comp
+        (swap! read-handlers merge-handlers read-handlers')]
-                     (filter :wfn)
-                     (map adapt-write-handler))
-                    handlers)
-          rhs (into {}
-                    (comp
-                     (filter :rfn)
-                     (map adapt-read-handler))
-                    handlers)
-          cwh (swap! write-handlers merge-and-clean whs)
-          crh (swap! read-handlers merge-and-clean rhs)]
 
-      (alter-var-root #'*write-handler-lookup* (constantly (-> cwh fres/associative-lookup fres/inheritance-lookup)))
+    (alter-var-root #'*write-handler-lookup*
-      (alter-var-root #'*read-handler-lookup* (constantly (-> crh fres/associative-lookup)))
+                    (constantly
-      nil)))
+                     (-> write-handlers' fres/associative-lookup fres/inheritance-lookup)))
+
+    (alter-var-root #'*read-handler-lookup*
+                    (constantly (-> read-handlers' fres/associative-lookup)))
+
+    nil))
+
+(defn overwrite-read-handlers
+  [& handlers]
+  (->> (into {} xf:adapt-read-handler handlers)
+       (merge-handlers @read-handlers)
+       (fres/associative-lookup)))
+
+(defn overwrite-write-handlers
+  [& handlers]
+  (->> (into {} xf:adapt-write-handler handlers)
+       (merge-handlers @write-handlers)
+       (fres/associative-lookup)
+       (fres/inheritance-lookup)))
 
 (defn write-char
   [n w o]

common/src/app/common/time.cljc

@@ -90,13 +90,22 @@
      (Clock/fixed ^Instant (inst instant)
                   ^ZoneId (ZoneId/of "Z"))))
 
-
-
 (defn now
   []
   #?(:clj (Instant/now *clock*)
      :cljs (new js/Date)))
 
+#?(:clj
+   (defn tick-millis-clock
+     "Alternate clock with a resolution of milliseconds instead of the default nanoseconds of the Java clock.
+      This may be useful if the instant is going to be serialized to DB with fressian (that does not have
+      resolution enough to store all precission) and need to compare the deserialized value for equality.
+
+      You can replace the global clock (for example in unit tests) with
+        (alter-var-root #'ct/*clock* (constantly (ct/tick-millis-clock)))"
+     []
+     (Clock/tickMillis (ZoneId/of "Z"))))
+
 ;; --- DURATION
 
 (defn- resolve-temporal-unit

common/src/app/common/types/token.cljc

@@ -144,6 +144,19 @@
         :gen/gen sg/text}
    token-name-validation-regex])
 
+(defn clean-token-name
+  "Remove all forbidden characters from token name and return a valid token name.
+   This is used for repairing invalid token names in old versions of Penpot."
+  [name]
+  (-> name
+      (str/replace "/" ".")
+      (str/replace " " "")
+      (str/replace #"^\$+" "")
+      (str/replace #"^\.+" "")
+      (str/replace #"\.+$" "")
+      (str/replace #"\.\.+" ".")
+      (str/replace #"[^a-zA-Z0-9$._-]" "?")))
+
 (def token-ref-validation-regex
   #"^\{[a-zA-Z0-9_-][a-zA-Z0-9$_-]*(\.[a-zA-Z0-9$_-]+)*\}$")
 

common/src/app/common/types/tokens_lib.cljc

@@ -242,17 +242,19 @@
   (update-token- [this token-id f]
     (assert (uuid? token-id) "expected uuid for `token-id`")
     (if-let [token (get-token- this token-id)]
-      (let [token' (-> (make-token (f token))
+      (let [token' (f token)]
-                       (assoc :modified-at (ct/now)))]
+        (if (not= token token')
-        (TokenSet. id
+          (let [token' (assoc token' :modified-at (ct/now))]
-                   name
+            (TokenSet. id
-                   description
+                       name
-                   (ct/now)
+                       description
-                   (if (= (:name token) (:name token'))
+                       (ct/now)
-                     (assoc tokens (:name token') token')
+                       (if (= (:name token) (:name token'))
-                     (-> tokens
+                         (assoc tokens (:name token') token')
-                         (d/oassoc-before (:name token) (:name token') token')
+                         (-> tokens
-                         (dissoc (:name token))))))
+                             (d/oassoc-before (:name token) (:name token') token')
+                             (dissoc (:name token))))))
+          this))
       this))
 
   (delete-token- [this token-id]
@@ -303,6 +305,35 @@
      (-clj->js [this]
        (clj->js (datafy this)))))
 
+(def ^:private set-prefix "S-")
+
+(def ^:private set-group-prefix "G-")
+
+(def ^:private set-separator "/")
+
+(defn get-set-path
+  [token-set]
+  (cpn/split-path (get-name token-set) :separator set-separator))
+
+(defn split-set-name
+  [name]
+  (cpn/split-path name :separator set-separator))
+
+(defn join-set-path [path]
+  (cpn/join-path path :separator set-separator :with-spaces? false))
+
+(defn normalize-set-name
+  "Normalize a set name (ensure that there are no extra spaces, like ' group /  set' -> 'group/set').
+
+  If `relative-to` is provided, the normalized name will preserve the same group prefix as reference name."
+  ([name]
+   (-> (split-set-name name)
+       (cpn/join-path :separator set-separator :with-spaces? false)))
+  ([name relative-to]
+   (-> (concat (butlast (split-set-name relative-to))
+               (split-set-name name))
+       (cpn/join-path :separator set-separator :with-spaces? false))))
+
 (defn token-set?
   [o]
   (instance? TokenSet o))
@@ -357,6 +388,7 @@
 (def check-token-set
   (sm/check-fn schema:token-set :hint "expected valid token set"))
 
+
 (defn map->token-set
   [& {:as attrs}]
   (TokenSet. (:id attrs)
@@ -372,38 +404,10 @@
       (update :modified-at #(or % (ct/now)))
       (update :tokens #(into (d/ordered-map) %))
       (update :description d/nilv "")
+      (update :name normalize-set-name)
       (check-token-set-attrs)
       (map->token-set)))
 
-(def ^:private set-prefix "S-")
-
-(def ^:private set-group-prefix "G-")
-
-(def ^:private set-separator "/")
-
-(defn get-set-path
-  [token-set]
-  (cpn/split-path (get-name token-set) :separator set-separator))
-
-(defn split-set-name
-  [name]
-  (cpn/split-path name :separator set-separator))
-
-(defn join-set-path [path]
-  (cpn/join-path path :separator set-separator :with-spaces? false))
-
-(defn normalize-set-name
-  "Normalize a set name (ensure that there are no extra spaces, like ' group /  set' -> 'group/set').
-
-  If `relative-to` is provided, the normalized name will preserve the same group prefix as reference name."
-  ([name]
-   (-> (split-set-name name)
-       (cpn/join-path :separator set-separator :with-spaces? false)))
-  ([name relative-to]
-   (-> (concat (butlast (split-set-name relative-to))
-               (split-set-name name))
-       (cpn/join-path :separator set-separator :with-spaces? false))))
-
 (defn normalized-set-name?
   "Check if a set name is normalized (no extra spaces)."
   [name]

common/test/common_tests/types/token_test.cljc

@@ -10,21 +10,42 @@
    [app.common.types.token :as cto]
    [clojure.test :as t]))
 
-(t/deftest test-valid-token-name-schema
+(t/deftest test-valid-token-name
   ;; Allow regular namespace token names
   (t/is (true? (sm/validate cto/schema:token-name "Foo")))
   (t/is (true? (sm/validate cto/schema:token-name "foo")))
   (t/is (true? (sm/validate cto/schema:token-name "FOO")))
   (t/is (true? (sm/validate cto/schema:token-name "Foo.Bar.Baz")))
-  ;; Disallow trailing tokens
+  ;; Allow $ inside or at the end of the name, but not at the beginning
+  (t/is (true? (sm/validate cto/schema:token-name "Foo$Bar$Baz")))
+  (t/is (true? (sm/validate cto/schema:token-name "Foo$Bar$Baz$")))
+  (t/is (false? (sm/validate cto/schema:token-name "$Foo$Bar$Baz")))
+  ;; Disallow starting and trailing dots
+  (t/is (false? (sm/validate cto/schema:token-name "....Foo.Bar.Baz")))
   (t/is (false? (sm/validate cto/schema:token-name "Foo.Bar.Baz....")))
   ;; Disallow multiple separator dots
   (t/is (false? (sm/validate cto/schema:token-name "Foo..Bar.Baz")))
   ;; Disallow any special characters
   (t/is (false? (sm/validate cto/schema:token-name "Hey Foo.Bar")))
-  (t/is (false? (sm/validate cto/schema:token-name "Hey😈Foo.Bar")))
+  (t/is (false? (sm/validate cto/schema:token-name "HeyÅFoo.Bar")))
-  (t/is (false? (sm/validate cto/schema:token-name "Hey%Foo.Bar"))))
+  (t/is (false? (sm/validate cto/schema:token-name "Hey%Foo.Bar")))
+  (t/is (false? (sm/validate cto/schema:token-name "Hey / Foo/Bar"))))
 
+(t/deftest test-clean-token-name
+  (t/is (= (cto/clean-token-name "Foo") "Foo"))
+  (t/is (= (cto/clean-token-name "foo") "foo"))
+  (t/is (= (cto/clean-token-name "FOO") "FOO"))
+  (t/is (= (cto/clean-token-name "Foo.Bar.Baz") "Foo.Bar.Baz"))
+  (t/is (= (cto/clean-token-name "Foo$Bar$Baz") "Foo$Bar$Baz"))
+  (t/is (= (cto/clean-token-name "Foo$Bar$Baz$") "Foo$Bar$Baz$"))
+  (t/is (= (cto/clean-token-name "$$$Foo$Bar$Baz") "Foo$Bar$Baz"))
+  (t/is (= (cto/clean-token-name "....Foo.Bar.Baz") "Foo.Bar.Baz"))
+  (t/is (= (cto/clean-token-name "Foo.Bar.Baz....") "Foo.Bar.Baz"))
+  (t/is (= (cto/clean-token-name "Foo..Bar...Baz") "Foo.Bar.Baz"))
+  (t/is (= (cto/clean-token-name "Hey Foo   Bar") "HeyFooBar"))
+  (t/is (= (cto/clean-token-name "HeyÅFoo.Bar") "Hey?Foo.Bar"))
+  (t/is (= (cto/clean-token-name "Hey%Foo.Bar") "Hey?Foo.Bar"))
+  (t/is (= (cto/clean-token-name "Hey / Foo/Bar") "Hey.Foo.Bar")))
 
 (t/deftest token-value-with-refs
   (t/testing "empty value"

common/test/common_tests/types/tokens_lib_test.cljc

@@ -11,7 +11,6 @@
    #?(:clj [app.common.test-helpers.tokens :as tht])
    #?(:clj [clojure.datafy :refer [datafy]])
    [app.common.data :as d]
-   [app.common.path-names :as cpn]
    [app.common.test-helpers.ids-map :as thi]
    [app.common.time :as ct]
    [app.common.transit :as tr]
@@ -2034,3 +2033,32 @@
   (t/is (true? (ctob/token-name-path-exists? "border-radius.sm.x" {"border-radius" {:name "sm"}})))
   (t/is (false? (ctob/token-name-path-exists? "other" {"border-radius" {:name "sm"}})))
   (t/is (false? (ctob/token-name-path-exists? "dark.border-radius.md" {"dark" {"border-radius" {"sm" {:name "sm"}}}}))))
+
+(t/deftest token-set-encode-decode-roundtrip-with-invalid-set-name
+  (binding [ct/*clock* (ct/tick-millis-clock)]
+    (let [tokens-lib
+          (-> (ctob/make-tokens-lib)
+              (ctob/add-set
+               (ctob/map->token-set
+                {:id (thi/new-id! :test-token-set)
+                 :name "foo / bar"
+                 :modified-at (ct/now)
+                 :description ""}))
+              (ctob/add-token
+               (thi/id :test-token-set)
+               (ctob/make-token :name "test-token-1"
+                                :type :boolean
+                                :value true)))
+
+          encoded-tokens-lib
+          (fres/encode tokens-lib)
+
+          decoded-tokens-lib
+          (fres/decode encoded-tokens-lib)]
+
+      (let [tset-a (ctob/get-set tokens-lib (thi/id :test-token-set))
+            tset-b (ctob/get-set decoded-tokens-lib (thi/id :test-token-set))]
+        (t/is (= (ctob/get-name tset-a) "foo / bar"))
+        (t/is (= (ctob/get-name tset-b) "foo/bar"))))))
+
+