✨ Support for upload embedded images

backend/src/app/util/http.clj

@@ -14,7 +14,9 @@
    [promesa.exec :as px]))
 
 (def default-client
-  (delay (http/build-client {:executor @px/default-executor})))
+  (delay (http/build-client {:executor @px/default-executor
+                             :connect-timeout 10000 ;; 10s
+                             :follow-redirects :always})))
 
 (defn get!
   [url opts]

frontend/src/app/main/data/workspace/persistence.cljs

@@ -32,6 +32,7 @@
    [app.util.router :as rt]
    [app.util.time :as dt]
    [app.util.transit :as t]
+   [app.util.uri :as uu]
    [beicon.core :as rx]
    [cljs.spec.alpha :as s]
    [cuerdas.core :as str]
@@ -404,17 +405,10 @@
                      (assoc result :name name)
                      (throw result)))))))
 
-(defn url-name [url]
-  (let [query-idx (str/last-index-of url "?")
-        url (if (> query-idx 0) (subs url 0 query-idx) url)
-        filename (->> (str/split url "/") (last))
-        ext-idx (str/last-index-of filename ".")]
-    (if (> ext-idx 0) (subs filename 0 ext-idx) filename)))
-
 (defn fetch-svg [name uri]
   (->> (http/send! {:method :get :uri uri})
        (rx/map #(vector
-                 (or name (url-name uri))
+                 (or name (uu/uri-name uri))
                  (:body %)))))
 
 (defn- handle-upload-error [on-error stream]
@@ -459,7 +453,7 @@
           (prepare-uri [uri]
             {:file-id file-id
              :is-local local?
-             :name (or name (url-name uri))
+             :name (or name (uu/uri-name uri))
              :url uri})]
     (rx/merge
      (->> (rx/from uris)
@@ -543,7 +537,7 @@
   [params position]
   (let [{:keys [x y]} position
         mdata  {:on-image #(st/emit! (dwc/image-uploaded % x y))
-                :on-svg   #(st/emit! (svg/svg-uploaded % x y))}
+                :on-svg   #(st/emit! (svg/svg-uploaded % (:file-id params) x y))}
 
         params (-> (assoc params :local? true)
                    (with-meta mdata))]

frontend/src/app/main/data/workspace/svg_upload.cljs

@@ -13,16 +13,20 @@
    [app.common.geom.matrix :as gmt]
    [app.common.geom.point :as gpt]
    [app.common.geom.shapes :as gsh]
+   [app.common.geom.proportions :as gpr]
    [app.common.pages :as cp]
    [app.common.uuid :as uuid]
    [app.main.data.workspace.common :as dwc]
+   [app.main.repo :as rp]
    [app.util.color :as uc]
    [app.util.geom.path :as ugp]
    [app.util.object :as obj]
    [app.util.svg :as usvg]
+   [app.util.uri :as uu]
    [beicon.core :as rx]
    [cuerdas.core :as str]
-   [potok.core :as ptk]))
+   [potok.core :as ptk]
+   [promesa.core :as p]))
 
 (defn- svg-dimensions [data]
   (let [width (get-in data [:attrs :width] 100)
@@ -138,7 +142,8 @@
 
 (defn create-path-shape [name frame-id svg-data {:keys [attrs] :as data}]
   (let [svg-transform (usvg/parse-transform (:transform attrs))
-        content (cond-> (ugp/path->content (:d attrs))
+        path-content (ugp/path->content (:d attrs))
+        content (cond-> path-content
                   svg-transform
                   (gsh/transform-content svg-transform))
 
@@ -189,7 +194,7 @@
         rect-points (gsh/rect->points rect-shape)
 
         [shape-transform shape-transform-inv rotation]
-        (gsh/calculate-adjust-matrix points rect-points)]
+        (gsh/calculate-adjust-matrix points rect-points (neg? (:a transform)) (neg? (:d transform)))]
 
     (merge rect-shape
            {:selrect selrect
@@ -265,6 +270,37 @@
         (assoc :svg-viewbox (select-keys rect [:x :y :width :height]))
         (assoc :svg-attrs (dissoc attrs :cx :cy :r :rx :ry :transform)))))
 
+(defn create-image-shape [name frame-id svg-data {:keys [attrs] :as data}]
+  (let [svg-transform (usvg/parse-transform (:transform attrs))
+        transform (->> svg-transform 
+                       (gmt/transform-in (gpt/point svg-data)))
+
+        image-url (:xlink:href attrs)
+        image-data (get-in svg-data [:image-data image-url])
+
+        rect (->> (select-keys attrs [:x :y :width :height])
+                  (d/mapm #(d/parse-double %2)))
+
+        origin (gpt/negate (gpt/point svg-data))
+
+        rect-data (-> (merge {:x 0 :y 0 :width (:width image-data) :height (:height image-data)} rect)
+                      (update :x - (:x origin))
+                      (update :y - (:y origin)))
+
+        rect-metadata (calculate-rect-metadata rect-data transform)]
+    (-> {:id (uuid/next)
+         :type :image
+         :name name
+         :frame-id frame-id
+         :metadata {:width (:width image-data)
+                    :height (:height image-data)
+                    :mtype (:mtype image-data)
+                    :id (:id image-data)}}
+
+        (merge rect-metadata)
+        (assoc :svg-viewbox (select-keys rect [:x :y :width :height]))
+        (assoc :svg-attrs (dissoc attrs :x :y :width :height :xlink:href)))))
+
 (defn parse-svg-element [frame-id svg-data element-data unames]
   (let [{:keys [tag attrs]} element-data
         attrs (usvg/format-styles attrs)
@@ -301,14 +337,14 @@
                          :ellipse) (create-circle-shape name frame-id svg-data element-data)
                         :path      (create-path-shape name frame-id svg-data element-data)
                         :polyline  (create-path-shape name frame-id svg-data (-> element-data usvg/polyline->path))
-                        :polygo    (create-path-shape name frame-id svg-data (-> element-data usvg/polygon->path))
+                        :polygon   (create-path-shape name frame-id svg-data (-> element-data usvg/polygon->path))
                         :line      (create-path-shape name frame-id svg-data (-> element-data usvg/line->path))
+                        :image     (create-image-shape name frame-id svg-data element-data)
                         #_other    (create-raw-svg name frame-id svg-data element-data))
 
                       (assoc :svg-defs (select-keys (:defs svg-data) references))
                       (setup-fill)
                       (setup-stroke))
-
             children (cond->> (:content element-data)
                        (= tag :g)
                        (mapv #(usvg/inherit-attributes attrs %)))]
@@ -335,8 +371,38 @@
         reducer-fn (partial add-svg-child-changes page-id objects selected frame-id shape-id svg-data)]
     (reduce reducer-fn [unames changes] (d/enumerate children))))
 
-(defn svg-uploaded [svg-data x y]
+(declare create-svg-shapes)
+
+(defn svg-uploaded [svg-data file-id x y]
   (ptk/reify ::svg-uploaded
+    ptk/WatchEvent
+    (watch [_ state stream]
+      (let [images-to-upload (-> svg-data (usvg/collect-images))
+
+            prepare-uri
+            (fn [uri]
+              (merge
+               {:file-id file-id
+                :is-local true
+                :url uri}
+
+               (if (str/starts-with? uri "data:")
+                 {:name "image"
+                  :content (uu/data-uri->blob uri)}
+                 {:name (uu/uri-name uri)})))]
+
+        (->> (rx/from images-to-upload)
+             (rx/map prepare-uri)
+             (rx/mapcat (fn [uri-data]
+                          (->> (rp/mutation! (if (contains? uri-data :content)
+                                               :upload-file-media-object
+                                               :create-file-media-object-from-url) uri-data)
+                               (rx/map #(vector (:url uri-data) %)))))
+             (rx/reduce (fn [acc [url image]] (assoc acc url image)) {})
+             (rx/map #(create-svg-shapes (assoc svg-data :image-data %) x y)))))))
+
+(defn create-svg-shapes [svg-data x y]
+  (ptk/reify ::create-svg-shapes
     ptk/WatchEvent
     (watch [_ state stream]
       (try
@@ -373,10 +439,14 @@
               root-shape (create-svg-root frame-id svg-data)
               root-id (:id root-shape)
 
+              ;; Creates the root shape
               changes (dwc/add-shape-changes page-id objects selected root-shape false)
 
-              reducer-fn (partial add-svg-child-changes page-id objects selected frame-id root-id svg-data)
+              ;; Reduces the children to create the changes to add the children shapes
-              [_ [rchanges uchanges]] (reduce reducer-fn [unames changes] (d/enumerate (:content svg-data)))
+              [_ [rchanges uchanges]]
+              (reduce (partial add-svg-child-changes page-id objects selected frame-id root-id svg-data)
+                      [unames changes]
+                      (d/enumerate (:content svg-data)))
 
               reg-objects-action {:type :reg-objects
                                   :page-id page-id

frontend/src/app/util/geom/path.cljs

@@ -228,43 +228,36 @@
     
     (mapv to-command result)))
 
+(defn smooth->curve
+  [{:keys [params]} pos handler]
+  (let [{c1x :x c1y :y} (calculate-opposite-handler pos handler)]
+    {:c1x c1x
+     :c1y c1y
+     :c2x (:cx params)
+     :c2y (:cy params)}))
+
+(defn quadratic->curve
+  [sp ep cp]
+  (let [cp1 (-> (gpt/to-vec sp cp)
+                (gpt/scale (/ 2 3))
+                (gpt/add sp))
+
+        cp2 (-> (gpt/to-vec ep cp)
+                (gpt/scale (/ 2 3))
+                (gpt/add ep))]
+
+    {:c1x (:x cp1)
+     :c1y (:y cp1)
+     :c2x (:x cp2)
+     :c2y (:y cp2)}))
+
 (defn simplify-commands
   "Removes some commands and convert relative to absolute coordinates"
   [commands]
-
+  (let [simplify-command
-  (let [smooth->curve (fn [{:keys [params]} pos]
+        ;; prev-cc : previous command control point for cubic beziers
-                        {:c1x (:x pos)
+        ;; prev-qc : previous command control point for quadratic curves
-                         :c1y (:y pos)
+        (fn [[pos result prev-cc prev-qc] [command prev]]
-                         :c2x (:cx params)
-                         :c2y (:cy params)})
-
-        quadratic->curve (fn [{:keys [params]} pos]
-                           (let [sp (gpt/point (:x pos) (:y pos)) ;; start point
-                                 ep (gpt/point (:x params) (:y params)) ;; end-point
-                                 cp (gpt/point (:cx params) (:cy params)) ;; control-point
-
-                                 cp1 (-> (gpt/to-vec sp cp)
-                                         (gpt/scale (/ 2 3))
-                                         (gpt/add sp))
-
-                                 cp2 (-> (gpt/to-vec ep cp)
-                                         (gpt/scale (/ 2 3))
-                                         (gpt/add ep))]
-
-                             {:c1x (:x cp1)
-                              :c1y (:y cp1)
-                              :c2x (:x cp2)
-                              :c2y (:y cp2)}))
-
-
-        smooth-quadratic->curve (fn [cmd {:keys [params]} pos]
-                                  (let [point (gpt/point (:x params) (:y params))
-                                        handler (gpt/point (:cx params) (:cy params))
-                                        oh (calculate-opposite-handler point handler)]
-                                    (quadratic->curve (update cmd :params assoc :cx (:x oh) :cy (:y oh)) pos)))
-        
-        simplify-command
-        (fn [[pos result] [command prev]]
           (let [command
                 (cond-> command
                   (:relative command)
@@ -282,13 +275,15 @@
                       (cd/update-in-when [:params :y] + (:y pos))
 
                       (cond->
-                        (= :line-to-horizontal (:command command))
+                          (= :line-to-horizontal (:command command))
                         (cd/update-in-when [:params :value] + (:x pos))  
                         
                         (= :line-to-vertical (:command command))
                         (cd/update-in-when [:params :value] + (:y pos)))))
 
                 params (:params command)
+                orig-command command
+
                 command
                 (cond-> command
                   (= :line-to-horizontal (:command command))
@@ -306,29 +301,49 @@
                   (= :smooth-curve-to (:command command))
                   (-> (assoc :command :curve-to)
                       (update :params dissoc :cx :cy)
-                      (update :params merge (smooth->curve command pos)))
+                      (update :params merge (smooth->curve command pos prev-cc)))
 
                   (= :quadratic-bezier-curve-to (:command command))
                   (-> (assoc :command :curve-to)
                       (update :params dissoc :cx :cy)
-                      (update :params merge (quadratic->curve command pos)))
+                      (update :params merge (quadratic->curve pos (gpt/point params) (gpt/point (:cx params) (:cy params)))))
 
                   (= :smooth-quadratic-bezier-curve-to (:command command))
                   (-> (assoc :command :curve-to)
-                      (update :params merge (smooth-quadratic->curve command prev pos))))
+                      (update :params merge (quadratic->curve pos (gpt/point params) (calculate-opposite-handler pos prev-qc)))))
                 
-                result #_(conj result command)
+                result (if (= :elliptical-arc (:command command))
-                (if (= :elliptical-arc (:command command))
+                         (cd/concat result (arc->beziers pos command))
-                  (cd/concat result (arc->beziers pos command))
+                         (conj result command))
-                  (conj result command))]
+
-            [(cmd-pos pos command) result]))
+                prev-cc (case (:command orig-command)
+                          :smooth-curve-to
+                          (gpt/point (get-in orig-command [:params :cx]) (get-in orig-command [:params :cy]))
+                          
+                          :curve-to
+                          (gpt/point (get-in orig-command [:params :c2x]) (get-in orig-command [:params :c2y]))
+
+                          (:line-to-horizontal :line-to-vertical)
+                          (gpt/point (get-in command [:params :x]) (get-in command [:params :y]))
+
+                          (gpt/point (get-in orig-command [:params :x]) (get-in orig-command [:params :y])))
+
+                prev-qc (case (:command orig-command)
+                          :quadratic-bezier-curve-to
+                          (gpt/point (get-in orig-command [:params :cx]) (get-in orig-command [:params :cy]))
+                          
+                          :smooth-quadratic-bezier-curve-to
+                          (calculate-opposite-handler pos prev-qc)
+                          
+                          (gpt/point (get-in orig-command [:params :x]) (get-in orig-command [:params :y])))]
+            [(cmd-pos pos command) result prev-cc prev-qc]))
 
         start (first commands)
         start-pos (gpt/point (:params start))]
 
     
     (->> (map vector (rest commands) commands)
-         (reduce simplify-command [start-pos [start]])
+         (reduce simplify-command [start-pos [start] start-pos start-pos])
          (second))))
 
 (defn path->content [string]

frontend/src/app/util/svg.cljs

@@ -17,10 +17,15 @@
    [app.common.math :as mth]
    [cuerdas.core :as str]))
 
-(defonce replace-regex #"#([^\W]+)")
+;; Regex for XML ids per Spec
+;; https://www.w3.org/TR/2008/REC-xml-20081126/#sec-common-syn
+(defonce xml-id-regex #"#([:A-Z_a-z\xC0-\xD6\xD8-\xF6\xF8-\u02FF\u0370-\u037D\u037F-\u1FFF\u200C-\u200D\u2070-\u218F\u2C00-\u2FEF\u3001-\uD7FF\uF900-\uFDCF\uFDF0-\uFFFD\u10000-\uEFFFF][\.\-\:0-9\xB7A-Z_a-z\xC0-\xD6\xD8-\xF6\xF8-\u02FF\u0300-\u036F\u0370-\u037D\u037F-\u1FFF\u200C-\u200D\u203F-\u2040\u2070-\u218F\u2C00-\u2FEF\u3001-\uD7FF\uF900-\uFDCF\uFDF0-\uFFFD\u10000-\uEFFFF]*)")
+
+(defonce matrices-regex #"(matrix|translate|scale|rotate|skewX|skewY)\(([^\)]*)\)")
+(defonce number-regex #"[+-]?\d*(\.\d+)?(e[+-]?\d+)?")
 
 (defn extract-ids [val]
-  (->> (re-seq replace-regex val)
+  (->> (re-seq xml-id-regex val)
        (mapv second)))
 
 (defn fix-dot-number
@@ -210,8 +215,6 @@
 ;; Transforms spec:
 ;; https://www.w3.org/TR/SVG11/single-page.html#coords-TransformAttribute
 
-(def matrices-regex #"(matrix|translate|scale|rotate|skewX|skewY)\(([^\)]*)\)")
-(def params-regex #"[+-]?\d*(\.\d+)?(e[+-]?\d+)?")
 
 (defn format-translate-params [params]
   (assert (or (= (count params) 1) (= (count params) 2)))
@@ -222,7 +225,7 @@
 (defn format-scale-params [params]
   (assert (or (= (count params) 1) (= (count params) 2)))
   (if (= (count params) 1)
-    [(gpt/point (mth/abs (nth params 0)))]
+    [(gpt/point (nth params 0))]
     [(gpt/point (nth params 0) (nth params 1))]))
 
 (defn format-rotate-params [params]
@@ -253,7 +256,7 @@
   (if transform-attr
     (let [process-matrix
           (fn [[_ type params]]
-            (let [params (->> (re-seq params-regex params)
+            (let [params (->> (re-seq number-regex params)
                               (filter #(-> % first empty? not))
                               (map (comp d/parse-double first)))]
               {:type type :params params}))
@@ -264,15 +267,16 @@
       (reduce gmt/multiply (gmt/matrix) matrices))
     (gmt/matrix)))
 
-(def points-regex #"[^\s\,]+")
+
 
 (defn format-move [[x y]] (str "M" x " " y))
 (defn format-line [[x y]] (str "L" x " " y))
 
 (defn points->path [points-str]
   (let [points (->> points-str
-                    (re-seq points-regex)
+                    (re-seq number-regex)
-                    (mapv d/parse-double)
+                    (filter (comp not empty? first))
+                    (mapv (comp d/parse-double first))
                     (partition 2))
 
         head (first points)
@@ -404,6 +408,23 @@
       (-> (mapfn)
           (d/update-when :content update-content)))))
 
+(defn reduce-nodes [redfn value node]
+  (let [reduce-content
+        (fn [value content]
+          (loop [current (first content)
+                 content (rest content)
+                 value value]
+            (if (nil? current)
+              value
+              (recur (first content)
+                     (rest content)
+                     (reduce-nodes redfn value current)))))]
+
+    (if (map? node)
+      (-> (redfn value node)
+          (reduce-content (:content node)))
+      value)))
+
 ;; Defaults for some tags per spec https://www.w3.org/TR/SVG11/single-page.html
 ;; they are basicaly the defaults that can be percents and we need to replace because
 ;; otherwise won't work as expected in the workspace
@@ -471,7 +492,7 @@
               (+ (get viewbox prop-coord)
                  (fix-length prop-length val)))
 
-            (fix-percent-attr [attr-key attr-val]
+            (fix-percent-attr-viewbox [attr-key attr-val]
               (let [is-percent? (str/ends-with? attr-val "%")
                     is-x? #{:x :x1 :x2 :cx}
                     is-y? #{:y :y1 :y2 :cy}
@@ -488,14 +509,39 @@
                            (is-width? attr-key)  (fix-length :width attr-num)
                            (is-height? attr-key) (fix-length :height attr-num)
                            (is-other? attr-key)  (fix-length :ratio attr-num)
-                           :else (do (.warn js/console "Percent property not converted!" (str attr-key) (str attr-val))
+                           :else attr-val)))
-                                     attr-val))))
                   attr-val)))
 
-            (fix-percent-attrs [attrs]
+            (fix-percent-attrs-viewbox [attrs]
-              (d/mapm fix-percent-attr attrs))
+              (d/mapm fix-percent-attr-viewbox attrs))
+
+            (fix-percent-attr-numeric [attr-key attr-val]
+              (let [is-percent? (str/ends-with? attr-val "%")]
+                (if is-percent?
+                  (str (let [attr-num (d/parse-double attr-val)]
+                         (/ attr-num 100)))
+                  attr-val)))
+
+            (fix-percent-attrs-numeric [attrs]
+              (d/mapm fix-percent-attr-numeric attrs))
 
             (fix-percent-values [node]
-              (update node :attrs fix-percent-attrs))]
+              (let [units (or (get-in node [:attrs :filterUnits])
+                              (get-in node [:attrs :gradientUnits])
+                              (get-in node [:attrs :patternUnits])
+                              (get-in node [:attrs :clipUnits]))]
+                (cond-> node
+                  (= "objectBoundingBox" units)
+                  (update :attrs fix-percent-attrs-numeric)
+
+                  (not= "objectBoundingBox" units)
+                  (update :attrs fix-percent-attrs-viewbox))))]
 
       (->> svg-data (map-nodes fix-percent-values)))))
+
+(defn collect-images [svg-data]
+  (let [redfn (fn [acc {:keys [tag attrs]}]
+                (cond-> acc
+                  (= :image tag)
+                  (conj (:xlink:href attrs))))]
+    (reduce-nodes redfn [] svg-data )))

frontend/src/app/util/uri.cljs

@@ -0,0 +1,38 @@
+;; 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) 2020-2021 UXBOX Labs SL
+
+(ns app.util.uri
+  (:require
+   [cuerdas.core :as str]
+   [app.util.object :as obj]))
+
+(defn uri-name [url]
+  (let [query-idx (str/last-index-of url "?")
+        url (if (> query-idx 0) (subs url 0 query-idx) url)
+        filename (->> (str/split url "/") (last))
+        ext-idx (str/last-index-of filename ".")]
+    (if (> ext-idx 0) (subs filename 0 ext-idx) filename)))
+
+(defn data-uri->blob
+  [data-uri]
+
+  (let [[mtype b64-data] (str/split data-uri ";base64,")
+
+        mtype (subs mtype (inc (str/index-of mtype ":")))
+        _ (prn "mtype" mtype)
+
+        decoded (.atob js/window b64-data)
+        size (.-length decoded)
+
+        content (js/Uint8Array. size)]
+
+    (doseq [i (range 0 size)]
+      (obj/set! content i (.charCodeAt decoded i)))
+
+    (js/Blob. #js [content] #js {"type" mtype})))