✨ Improve text shape tracing process on exporter.

Fixes many bugs related to the svgo removal and remove
unneded neesting of groups.

exporter/src/app/http/export_svg.cljs

@@ -5,95 +5,114 @@
 ;; This Source Code Form is "Incompatible With Secondary Licenses", as
 ;; defined by the Mozilla Public License, v. 2.0.
 ;;
-;; Copyright (c) 2020-2021 UXBOX Labs SL
+;; Copyright (c) UXBOX Labs SL
 
 (ns app.http.export-svg
   (:require
-   [cuerdas.core :as str]
+   ["path" :as path]
-   [clojure.walk :as walk]
+   ["xml-js" :as xml]
    [app.browser :as bwr]
-   [app.config :as cfg]
-   [lambdaisland.glogi :as log]
-   [cljs.spec.alpha :as s]
-   [promesa.core :as p]
-   [app.common.exceptions :as exc :include-macros true]
    [app.common.data :as d]
+   [app.common.exceptions :as exc :include-macros true]
    [app.common.pages :as cp]
    [app.common.spec :as us]
-   ["xml-js" :as xml]
+   [app.config :as cfg]
-   ["child_process" :as chp]
+   [app.util.shell :as sh]
-   ["os" :as os]
+   [cljs.spec.alpha :as s]
-   ["path" :as path]
+   [clojure.walk :as walk]
-   ["fs" :as fs])
+   [cuerdas.core :as str]
+   [lambdaisland.glogi :as log]
+   [promesa.core :as p])
   (:import
    goog.Uri))
 
 (log/set-level "app.http.export-svg" :trace)
 
-(defn- create-tmpdir!
+(defn- xml->clj
-  [prefix]
-  (p/create
-   (fn [resolve reject]
-     (fs/mkdtemp (path/join (os/tmpdir) prefix)
-                 (fn [err dir]
-                   (if err
-                     (reject err)
-                     (resolve dir)))))))
-
-(defn- write-file!
-  [fpath content]
-  (p/create
-   (fn [resolve reject]
-     (fs/writeFile fpath content (fn [err]
-                                   (if err
-                                     (reject err)
-                                     (resolve nil)))))))
-(defn- read-file
-  [fpath]
-  (p/create
-   (fn [resolve reject]
-     (fs/readFile fpath (fn [err content]
-                          (if err
-                            (reject err)
-                            (resolve content)))))))
-
-(defn- run-cmd!
-  [cmd]
-  (p/create
-   (fn [resolve reject]
-     (log/trace :fn :run-cmd :cmd cmd)
-     (chp/exec cmd #js {:encoding "buffer"}
-               (fn [error stdout stderr]
-                 ;; (log/trace :fn :run-cmd :stdout stdout)
-                 (if error
-                   (reject error)
-                   (resolve stdout)))))))
-
-(defn- rmdir!
-  [path]
-  (p/create
-   (fn [resolve reject]
-     (fs/rmdir path #js {:recursive true}
-               (fn [err]
-                 (if err
-                   (reject err)
-                   (resolve nil)))))))
-
-(defn- parse-xml
   [data]
   (js->clj (xml/xml2js data)))
 
-(defn- encode-xml
+(defn- clj->xml
   [data]
   (xml/js2xml (clj->js data)))
 
+(defn ^boolean empty-defs-element?
+  [item]
+  (and (= (get item "name") "defs")
+       (nil? (get item "attributes"))
+       (nil? (get item "elements"))))
+
+(defn ^boolean empty-path-element?
+  [item]
+  (and (= (get item "name") "path")
+       (let [d (get item ["attributes" "d"])]
+         (or (str/blank? d)
+             (nil? d)
+             (str/empty? d)))))
+
+(defn ^boolean foreign-object-element?
+  [item]
+  (and (map? item)
+       (= "foreignObject" (get item "name"))))
+
+(defn flatten-toplevel-svg-elements
+  "Flattens XML data structure if two nested top-side SVG elements found."
+  [item]
+  (if (and (= "svg" (get-in item ["elements" 0 "name"]))
+           (= "svg" (get-in item ["elements" 0 "elements" 0 "name"])))
+    (update-in item ["elements" 0] assoc "elements" (get-in item ["elements" 0 "elements" 0 "elements"]))
+    item))
+
+(defn replace-text-nodes
+  "Function responsible of replace the foreignObject elements on the
+  provided XML with the previously rasterized PATH's."
+  [xmldata nodes]
+  (letfn [(replace-fobject [item]
+            (if (foreign-object-element? item)
+              (let [id   (get-in item ["attributes" "id"])
+                    node (get nodes id)]
+                (if node
+                  (:svgdata node)
+                  item))
+              item))
+
+          (process-element [item xform]
+            (let [item (d/update-when item "elements" #(into [] xform %))]
+              (if (str/starts-with? (get-in item ["attributes" "id"]) "shape-")
+                (assoc item "elements" (get-in item ["elements" 0 "elements"]))
+                item)))]
+
+    (let [xform (comp (remove empty-defs-element?)
+                      (remove empty-path-element?)
+                      (map replace-fobject))]
+      (->> xmldata
+           (xml->clj)
+           (flatten-toplevel-svg-elements)
+           (walk/prewalk (fn [item]
+                           (cond-> item
+                             (and (map? item)
+                                  (string? (get item "name"))
+                                  (= "element" (get item "type")))
+                             (process-element xform))))
+           (clj->xml)))))
+
+(defn parse-viewbox
+  "Parses viewBox string into width & height map."
+  [data]
+  (let [[width height] (->> (str/split data #"\s+")
+                            (drop 2)
+                            (map d/parse-double))]
+    {:width width
+     :height height}))
+
+
 (defn- render-object
   [browser {:keys [page-id file-id object-id token scale suffix type]}]
   (letfn [(convert-to-ppm [pngpath]
             (log/trace :fn :convert-to-ppm)
             (let [basepath (path/dirname pngpath)
                   ppmpath  (path/join basepath "origin.ppm")]
-              (-> (run-cmd! (str "convert " pngpath " " ppmpath))
+              (-> (sh/run-cmd! (str "convert " pngpath " " ppmpath))
                   (p/then (constantly ppmpath)))))
 
           (trace-color-mask [pbmpath]
@@ -101,56 +120,72 @@
             (let [basepath (path/dirname pbmpath)
                   basename (path/basename pbmpath ".pbm")
                   svgpath  (path/join basepath (str basename ".svg"))]
-              (-> (run-cmd! (str "potrace --flat -b svg " pbmpath " -o " svgpath))
+              (-> (sh/run-cmd! (str "potrace --flat -b svg " pbmpath " -o " svgpath))
                   (p/then (constantly svgpath)))))
 
-          (generate-color-mask [ppmpath color]
+          (generate-color-layer [ppmpath color]
-            (log/trace :fn :generate-color-mask :ppmpath ppmpath :color color)
+            (log/trace :fn :generate-color-layer :ppmpath ppmpath :color color)
             (let [basepath (path/dirname ppmpath)
                   pbmpath  (path/join basepath (str "mask-" (subs color 1) ".pbm"))]
-              (-> (run-cmd! (str/format "ppmcolormask \"%s\" %s" color ppmpath))
+              (-> (sh/run-cmd! (str/format "ppmcolormask \"%s\" %s" color ppmpath))
                   (p/then (fn [stdout]
-                            (-> (write-file! pbmpath stdout)
+                            (-> (sh/write-file! pbmpath stdout)
                                 (p/then (constantly pbmpath)))))
                   (p/then trace-color-mask)
-                  (p/then read-file)
+                  (p/then sh/read-file)
                   (p/then (fn [data]
-                            (p/let [data (parse-xml data)
+                            (p/let [data (xml->clj data)
-                                    data (get-in data ["elements" 0])]
+                                    data (get-in data ["elements" 1])]
                               {:color   color
                                :svgdata data}))))))
 
-          (join-color-layers [layers]
+          (join-color-layers [{:keys [x y width height] :as node} layers]
             (log/trace :fn :join-color-layers)
-            (loop [main   (-> (:svgdata (first layers))
+            (loop [result (-> (:svgdata (first layers))
                               (assoc "elements" []))
                    layers (seq layers)]
-              (if (nil? layers)
+              (if-let [{:keys [color svgdata]} (first layers)]
-                main
+                (recur (->> (get svgdata "elements")
-                (let [layer    (first layers)
+                            (filter #(= (get % "name") "g"))
-                      elements (map (fn [element]
+                            (map #(update % "attributes" assoc "fill" color))
-                                      (update element "attributes" assoc "fill" (:color layer)))
+                            (update result "elements" d/concat))
-                                    (get-in layer [:svgdata "elements"] []))]
+                       (rest layers))
-                  (recur (update main "elements" d/concat elements)
-                         (next layers))))))
 
-          (convert-to-svg [colors ppmpath]
+                ;; Now we have the result containing the svgdata of a
+                ;; SVG with all text layers. Now we need to transform
+                ;; this SVG to G (Group) and remove unnecesary metada
+                ;; objects.
+                (let [vbox      (-> (get-in result ["attributes" "viewBox"])
+                                    (parse-viewbox))
+                      transform (str/fmt "translate(%s, %s) scale(%s, %s)" x y (/ width (:width vbox)) (/ height (:height vbox)))]
+                  (-> result
+                      (assoc "name" "g")
+                      (assoc "attributes" {})
+                      (update "elements" (fn [elements]
+                                           (mapv (fn [group]
+                                                   (let [paths (get group "elements")]
+                                                     (if (= 1 (count paths))
+                                                       (let [path (first paths)]
+                                                         (update path "attributes"
+                                                                 (fn [attrs]
+                                                                   (-> attrs
+                                                                       (d/merge (get group "attributes"))
+                                                                       (update "transform" #(str transform " " %))))))
+                                                       (update-in group ["attributes" "transform"] #(str transform " " %)))))
+                                                 elements))))))))
+
+          (convert-to-svg [ppmpath {:keys [colors] :as node}]
             (log/trace :fn :convert-to-svg :ppmpath ppmpath :colors colors)
-            (-> (p/all (map (partial generate-color-mask ppmpath) colors))
+            (-> (p/all (map (partial generate-color-layer ppmpath) colors))
-                (p/then join-color-layers)))
+                (p/then (partial join-color-layers node))))
 
-          (trace-single-node [{:keys [data] :as node}]
+          (trace-node [{:keys [data] :as node}]
-            (log/trace :fn :trace-single-node)
+            (log/trace :fn :trace-node)
-            (p/let [tdpath  (create-tmpdir! "svgexport-")
+            (p/let [tdpath  (sh/create-tmpdir! "svgexport-")
                     pngpath (path/join tdpath "origin.png")
-                    _       (write-file! pngpath data)
+                    _       (sh/write-file! pngpath data)
                     ppmpath (convert-to-ppm pngpath)
-                    svgdata (convert-to-svg (:colors node) ppmpath)
+                    svgdata (convert-to-svg ppmpath node)]
-                    svgdata (update svgdata "attributes" assoc
-                                    "width" (:width node)
-                                    "height" (:height node)
-                                    "x" (:x node)
-                                    "y" (:y node))]
               (-> node
                   (dissoc :data)
                   (assoc :tempdir tdpath
@@ -181,51 +216,26 @@
 
           (clean-temp-data [{:keys [tempdir] :as node}]
             (p/do!
-             (rmdir! tempdir)
+             (sh/rmdir! tempdir)
              (dissoc node :tempdir)))
 
-          (process-single-text-node [item]
+          (process-text-node [item]
             (-> (p/resolved item)
                 (p/then extract-single-node)
-                (p/then trace-single-node)
+                (p/then trace-node)
                 (p/then clean-temp-data)))
 
           (process-text-nodes [page]
             (log/trace :fn :process-text-nodes)
             (-> (bwr/select-all page "#screenshot foreignObject")
-                (p/then (fn [nodes]
+                (p/then (fn [nodes] (p/all (map process-text-node nodes))))))
-                          (reduce (fn [res node]
-                                    (p/then res (fn [res]
-                                                  (-> (process-single-text-node node)
-                                                      (p/then (fn [result]
-                                                                (conj res result)))))))
-                                  (p/resolved [])
-                                  nodes)))))
 
-          (replace-nodes-on-main [main nodes]
+          (extract-svg [page]
-            (let [main  (parse-xml main)
-                  index (d/index-by :id nodes)
-                  main  (walk/prewalk (fn [form]
-                                        (cond
-                                          (and (map? form)
-                                               (= "element" (get form "type"))
-                                               (= "foreignObject" (get form "name")))
-                                          (let [id   (get-in form ["attributes" "id"])
-                                                node (get index id)]
-                                            (if node
-                                              (:svgdata node)
-                                              form))
-
-                                          :else
-                                          form))
-                                      main)]
-              (encode-xml main)))
-
-          (render-svg [page]
             (p/let [dom     (bwr/select page "#screenshot")
-                    main  (bwr/eval! dom (fn [elem] (.-outerHTML ^js elem)))
+                    xmldata (bwr/eval! dom (fn [elem] (.-outerHTML ^js elem)))
-                    nodes (process-text-nodes page)]
+                    nodes   (process-text-nodes page)
-              (replace-nodes-on-main main nodes)))
+                    nodes   (d/index-by :id nodes)]
+              (replace-text-nodes xmldata nodes)))
 
           (render-in-page [page {:keys [uri cookie] :as rctx}]
             (p/do!
@@ -240,7 +250,7 @@
 
           (handle [rctx page]
             (p/let [page (render-in-page page rctx)]
-              (render-svg page)))]
+              (extract-svg page)))]
 
     (let [path (str "/render-object/" file-id "/" page-id "/" object-id)
           uri  (doto (Uri. (:public-uri cfg/config))

exporter/src/app/util/shell.cljs

@@ -0,0 +1,71 @@
+;; 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/.
+;;
+;; This Source Code Form is "Incompatible With Secondary Licenses", as
+;; defined by the Mozilla Public License, v. 2.0.
+;;
+;; Copyright (c) UXBOX Labs SL
+
+(ns app.util.shell
+  "Shell & FS utilities."
+  (:require
+   ["child_process" :as chp]
+   ["fs" :as fs]
+   ["os" :as os]
+   ["path" :as path]
+   [lambdaisland.glogi :as log]
+   [promesa.core :as p]))
+
+(log/set-level "app.util.shell" :trace)
+
+(defn create-tmpdir!
+  [prefix]
+  (p/create
+   (fn [resolve reject]
+     (fs/mkdtemp (path/join (os/tmpdir) prefix)
+                 (fn [err dir]
+                   (if err
+                     (reject err)
+                     (resolve dir)))))))
+
+(defn write-file!
+  [fpath content]
+  (p/create
+   (fn [resolve reject]
+     (fs/writeFile fpath content (fn [err]
+                                   (if err
+                                     (reject err)
+                                     (resolve nil)))))))
+(defn read-file
+  [fpath]
+  (p/create
+   (fn [resolve reject]
+     (fs/readFile fpath (fn [err content]
+                          (if err
+                            (reject err)
+                            (resolve content)))))))
+
+(defn run-cmd!
+  [cmd]
+  (p/create
+   (fn [resolve reject]
+     (log/trace :fn :run-cmd :cmd cmd)
+     (chp/exec cmd #js {:encoding "buffer"}
+               (fn [error stdout stderr]
+                 ;; (log/trace :fn :run-cmd :stdout stdout)
+                 (if error
+                   (reject error)
+                   (resolve stdout)))))))
+
+(defn rmdir!
+  [path]
+  (p/create
+   (fn [resolve reject]
+     (fs/rmdir path #js {:recursive true}
+               (fn [err]
+                 (if err
+                   (reject err)
+                   (resolve nil)))))))
+
+

frontend/src/app/main/ui/shapes/text.cljs

@@ -88,10 +88,8 @@
   [shape]
   (let [colors (->> (:content shape)
                     (tree-seq map? :children)
-                    (into #{} (comp (map :fill-color) (filter string?))))]
+                    (into #{"#000000"} (comp (map :fill-color) (filter string?))))]
-    (if (empty? colors)
+    (apply str (interpose "," colors))))
-      "#000000"
-      (apply str (interpose "," colors)))))
 
 (mf/defc text-shape
   {::mf/wrap-props false

manage.sh

@@ -73,18 +73,6 @@ function build {
            $DEVENV_IMGNAME:latest sudo -EH -u penpot ./scripts/build.sh
 }
 
-function build-frontend {
-    build "frontend";
-}
-
-function build-exporter {
-    build "exporter";
-}
-
-function build-backend {
-    build "backend";
-}
-
 function build-app-bundle {
     local version="$CURRENT_VERSION";
     local bundle_dir="./bundle-app";