penpot/frontend/src/app/worker/export.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.worker.export
  (:require
   [app.common.data :as d]
   [app.common.media :as cm]
   [app.common.text :as ct]
   [app.config :as cfg]
   [app.main.render :as r]
   [app.main.repo :as rp]
   [app.util.http :as http]
   [app.util.json :as json]
   [app.util.webapi :as wapi]
   [app.util.zip :as uz]
   [app.worker.impl :as impl]
   [beicon.core :as rx]
   [cuerdas.core :as str]))

(def ^:const current-version 2)

(defn create-manifest
  "Creates a manifest entry for the given files"
  [team-id file-id export-type files components-v2]
  (letfn [(format-page [manifest page]
            (-> manifest
                (assoc (str (:id page))
                       {:name (:name page)})))

          (format-file [manifest file]
            (let [name      (:name file)
                  is-shared (:is-shared file)
                  pages     (->> (get-in file [:data :pages])
                                 (mapv str))
                  index     (->> (get-in file [:data :pages-index])
                                 (vals)
                                 (reduce format-page {}))
                  features  (cond-> []
                              components-v2
                              (conj "components/v2"))]
              (-> manifest
                  (assoc (str (:id file))
                         {:name                 name
                          :features             features
                          :shared               is-shared
                          :pages                pages
                          :pagesIndex           index
                          :version              current-version
                          :libraries            (->> (:libraries file) (into #{}) (mapv str))
                          :exportType           (d/name export-type)
                          :hasComponents        (d/not-empty? (get-in file [:data :components]))
                          :hasDeletedComponents (d/not-empty? (get-in file [:data :deleted-components]))
                          :hasMedia             (d/not-empty? (get-in file [:data :media]))
                          :hasColors            (d/not-empty? (get-in file [:data :colors]))
                          :hasTypographies      (d/not-empty? (get-in file [:data :typographies]))}))))]
    (let [manifest {:teamId (str team-id)
                    :fileId (str file-id)
                    :files (->> (vals files) (reduce format-file {}))}]
      (json/encode manifest))))

(defn process-pages [file]
  (let [pages (get-in file [:data :pages])
        pages-index (get-in file [:data :pages-index])]
    (->> pages
         (map #(hash-map
                :file-id (:id file)
                :data (get pages-index %))))))

(defn get-page-data
  [{file-id :file-id {:keys [id name] :as data} :data}]
  (->> (r/render-page data)
       (rx/map (fn [markup]
                 {:id id
                  :name name
                  :file-id file-id
                  :markup markup}))))

(defn collect-page
  [{:keys [id file-id markup] :as page}]
  [(str file-id "/" id ".svg") markup])

(defn collect-entries [result data keys]
  (-> result
      (assoc (str (:id data))
             (->> (select-keys data keys)
                  (d/deep-mapm
                   (fn [[k v]]
                     [(-> k str/camel) v]))))))

(def ^:const color-keys
  [:name :color :opacity :gradient :path])

(def ^:const typography-keys
  [:name :font-family :font-id :font-size :font-style :font-variant-id :font-weight
   :letter-spacing :line-height :text-transform :path])

(def ^:const media-keys
  [:name :mtype :width :height :path])

(defn collect-color
  [result color]
  (collect-entries result color color-keys))

(defn collect-typography
  [result typography]
  (collect-entries result typography typography-keys))

(defn collect-media
  [result media]
  (collect-entries result media media-keys))

(defn parse-library-color
  [[file-id colors]]
  (let [markup
        (->> (vals colors)
             (reduce collect-color {})
             (json/encode))]
    [(str file-id "/colors.json") markup]))

(defn parse-library-typographies
  [[file-id typographies]]
  (let [markup
        (->> (vals typographies)
             (reduce collect-typography {})
             (json/encode))]
    [(str file-id "/typographies.json") markup]))

(defn parse-library-media
  [[file-id media]]
  (rx/merge
   (let [markup
         (->> (vals media)
              (reduce collect-media {})
              (json/encode))]
     (rx/of (vector (str file-id "/media.json") markup)))

   (->> (rx/from (vals media))
        (rx/map #(assoc % :file-id file-id))
        (rx/flat-map
         (fn [media]
           (let [file-path (str/concat file-id "/media/" (:id media) (cm/mtype->extension (:mtype media)))]
             (->> (http/send!
                   {:uri (cfg/resolve-file-media media)
                    :response-type :blob
                    :method :get})
                  (rx/map :body)
                  (rx/map #(vector file-path %)))))))))

(defn parse-library-components
  [file]
  (->> (r/render-components (:data file) :components)
       (rx/map #(vector (str (:id file) "/components.svg") %))))

(defn parse-deleted-components
  [file]
  (->> (r/render-components (:data file) :deleted-components)
       (rx/map #(vector (str (:id file) "/deleted-components.svg") %))))

(defn fetch-file-with-libraries
  [file-id components-v2]
  (let [features (cond-> #{} components-v2 (conj "components/v2"))]
    (->> (rx/zip (rp/cmd! :get-file {:id file-id :features features})
                 (rp/cmd! :get-file-libraries {:file-id file-id}))
         (rx/map
          (fn [[file file-libraries]]
            (let [libraries-ids (->> file-libraries (map :id) (filterv #(not= (:id file) %)))]
              (assoc file :libraries libraries-ids)))))))

(defn get-component-ref-file
  [objects shape]

  (cond
    (contains? shape :component-file)
    (get shape :component-file)

    (contains? shape :shape-ref)
    (recur objects (get objects (:parent-id shape)))

    :else
    nil))

(defn detach-external-references
  [file file-id]
  (let [detach-text
        (fn [content]
          (->> content
               (ct/transform-nodes
                #(cond-> %
                   (not= file-id (:fill-color-ref-file %))
                   (dissoc :fill-color-ref-id :fill-color-ref-file)

                   (not= file-id (:typography-ref-file %))
                   (dissoc :typography-ref-id :typography-ref-file)))))

        detach-shape
        (fn [objects shape]
          (cond-> shape
            (not= file-id (:fill-color-ref-file shape))
            (dissoc :fill-color-ref-id :fill-color-ref-file)

            (not= file-id (:stroke-color-ref-file shape))
            (dissoc :stroke-color-ref-id :stroke-color-ref-file)

            (not= file-id (get-component-ref-file objects shape))
            (dissoc :component-id :component-file :shape-ref :component-root?)

            (= :text (:type shape))
            (update :content detach-text)))

        detach-objects
        (fn [objects]
          (->> objects
               (d/mapm #(detach-shape objects %2))))

        detach-pages
        (fn [pages-index]
          (->> pages-index
               (d/mapm
                (fn [_ data]
                  (-> data
                      (update :objects detach-objects))))))]

    (-> file
        (update-in [:data :pages-index] detach-pages))))

(defn make-local-external-references
  [file file-id]
  (let [detach-text
        (fn [content]
          (->> content
               (ct/transform-nodes
                #(cond-> %
                   (not= file-id (:fill-color-ref-file %))
                   (assoc :fill-color-ref-file file-id)

                   (not= file-id (:typography-ref-file %))
                   (assoc :typography-ref-file file-id)))))

        detach-shape
        (fn [shape]
          (cond-> shape
            (not= file-id (:fill-color-ref-file shape))
            (assoc :fill-color-ref-file file-id)

            (not= file-id (:stroke-color-ref-file shape))
            (assoc :stroke-color-ref-file file-id)

            (not= file-id (:component-file shape))
            (assoc :component-file file-id)

            (= :text (:type shape))
            (update :content detach-text)))

        detach-objects
        (fn [objects]
          (->> objects
               (d/mapm #(detach-shape %2))))

        detach-pages
        (fn [pages-index]
          (->> pages-index
               (d/mapm
                (fn [_ data]
                  (-> data
                      (update :objects detach-objects))))))]
    (-> file
        (update-in [:data :pages-index] detach-pages))))

(defn collect-external-references
  [file]

  (let [get-text-refs
        (fn [content]
          (->> content
               (ct/node-seq #(or (contains? % :fill-color-ref-id)
                                 (contains? % :typography-ref-id)))

               (mapcat (fn [node]
                         (cond-> []
                           (contains? node :fill-color-ref-id)
                           (conj {:id (:fill-color-ref-id node)
                                  :file-id (:fill-color-ref-file node)})

                           (contains? node :typography-ref-id)
                           (conj {:id (:typography-ref-id node)
                                  :file-id (:typography-ref-file node)})
                           )))

               (into [])))

        get-shape-refs
        (fn [[_ shape]]
          (cond-> []
            (contains? shape :fill-color-ref-id)
            (conj {:id (:fill-color-ref-id shape)
                   :file-id (:fill-color-ref-file shape)})

            (contains? shape :stroke-color-ref-id)
            (conj {:id (:stroke-color-ref-id shape)
                   :file-id (:stroke-color-ref-file shape)})

            (contains? shape :component-id)
            (conj {:id (:component-id shape)
                   :file-id (:component-file shape)})

            (= :text (:type shape))
            (into (get-text-refs (:content shape)))))]

    (->> (get-in file [:data :pages-index])
         (vals)
         (mapcat :objects)
         (mapcat get-shape-refs)
         (filter (comp some? :file-id))
         (filter (comp some? :id))
         (group-by :file-id)
         (d/mapm #(mapv :id %2)))))

(defn merge-assets [target-file assets-files]
  (let [external-refs (collect-external-references target-file)

        merge-file-assets
        (fn [target file]
          (let [colors       (-> (get-in file [:data :colors])
                                 (select-keys (get external-refs (:id file))))
                typographies (-> (get-in file [:data :typographies])
                                 (select-keys (get external-refs (:id file))))
                media        (-> (get-in file [:data :media])
                                 (select-keys (get external-refs (:id file))))
                components   (-> (get-in file [:data :components])
                                 (select-keys (get external-refs (:id file))))]
            (cond-> target
              (d/not-empty? colors)
              (update-in [:data :colors] merge colors)

              (d/not-empty? typographies)
              (update-in [:data :typographies] merge typographies)

              (d/not-empty? media)
              (update-in [:data :media] merge media)

              (d/not-empty? components)
              (update-in [:data :components] merge components))))]

    (->> assets-files
         (reduce merge-file-assets target-file))))

(defn process-export
  [file-id export-type files]

  (case export-type
    :all      files
    :merge    (let [file-list (-> files (d/without-keys [file-id]) vals)]
                (-> (select-keys files [file-id])
                    (update file-id merge-assets file-list)
                    (update file-id make-local-external-references file-id)
                    (update file-id dissoc :libraries)))
    :detach (-> (select-keys files [file-id])
                (update file-id detach-external-references file-id)
                (update file-id dissoc :libraries))))

(defn collect-files
  [file-id export-type components-v2]

  (letfn [(fetch-dependencies [[files pending]]
            (if (empty? pending)
              ;; When not pending, we finish the generation
              (rx/empty)

              ;; Still pending files, fetch the next one
              (let [next    (peek pending)
                    pending (pop pending)]
                (if (contains? files next)
                  ;; The file is already in the result
                  (rx/of [files pending])

                  (->> (fetch-file-with-libraries next components-v2)
                       (rx/map
                        (fn [file]
                          [(-> files
                               (assoc (:id file) file))
                           (as-> pending $
                             (reduce conj $ (:libraries file)))])))))))]
    (let [files {}
          pending [file-id]]
      (->> (rx/of [files pending])
           (rx/expand fetch-dependencies)
           (rx/last)
           (rx/map first)
           (rx/map #(process-export file-id export-type %))))))

(defn export-file
  [team-id file-id export-type components-v2]

  (let [files-stream (->> (collect-files file-id export-type components-v2)
                          (rx/share))

        manifest-stream
        (->> files-stream
             (rx/map #(create-manifest team-id file-id export-type % components-v2))
             (rx/map #(vector "manifest.json" %)))

        render-stream
        (->> files-stream
             (rx/flat-map vals)
             (rx/flat-map process-pages)
             (rx/observe-on :async)
             (rx/flat-map get-page-data)
             (rx/share))

        colors-stream
        (->> files-stream
             (rx/flat-map vals)
             (rx/map #(vector (:id %) (get-in % [:data :colors])))
             (rx/filter #(d/not-empty? (second %)))
             (rx/map parse-library-color))

        typographies-stream
        (->> files-stream
             (rx/flat-map vals)
             (rx/map #(vector (:id %) (get-in % [:data :typographies])))
             (rx/filter #(d/not-empty? (second %)))
             (rx/map parse-library-typographies))

        media-stream
        (->> files-stream
             (rx/flat-map vals)
             (rx/map #(vector (:id %) (get-in % [:data :media])))
             (rx/filter #(d/not-empty? (second %)))
             (rx/flat-map parse-library-media))

        components-stream
        (->> files-stream
             (rx/flat-map vals)
             (rx/filter #(d/not-empty? (get-in % [:data :components])))
             (rx/flat-map parse-library-components))

        deleted-components-stream
        (->> files-stream
             (rx/flat-map vals)
             (rx/filter #(d/not-empty? (get-in % [:data :deleted-components])))
             (rx/flat-map parse-deleted-components))

        pages-stream
        (->> render-stream
             (rx/map collect-page))]

    (rx/merge
     (->> render-stream
          (rx/map #(hash-map
                    :type :progress
                    :file file-id
                    :data (str "Render " (:file-name %) " - " (:name %)))))

     (->> (rx/merge
           manifest-stream
           pages-stream
           components-stream
           deleted-components-stream
           media-stream
           colors-stream
           typographies-stream)
          (rx/reduce conj [])
          (rx/with-latest-from files-stream)
          (rx/flat-map (fn [[data files]]
                         (->> (uz/compress-files data)
                              (rx/map #(vector (get files file-id) %)))))))))

(defmethod impl/handler :export-binary-file
  [{:keys [files export-type] :as message}]
  (->> (rx/from files)
       (rx/mapcat
        (fn [file]
          (->> (rp/command! :export-binfile {:file-id (:id file)
                                             :include-libraries? (= export-type :all)
                                             :embed-assets? (= export-type :merge)})
               (rx/map #(hash-map :type :finish
                                  :file-id (:id file)
                                  :filename (:name file)
                                  :mtype "application/penpot"
                                  :description "Penpot export (*.penpot)"
                                  :uri (wapi/create-uri (wapi/create-blob %))))
               (rx/catch
                (fn [err]
                  (rx/of {:type :error
                          :error (str err)
                          :file-id (:id file)}))))))))

(defmethod impl/handler :export-standard-file
  [{:keys [team-id files export-type components-v2] :as message}]

  (->> (rx/from files)
       (rx/mapcat
        (fn [file]
          (->> (export-file team-id (:id file) export-type components-v2)
               (rx/map
                (fn [value]
                  (if (contains? value :type)
                    value
                    (let [[file export-blob] value]
                      {:type :finish
                       :file-id (:id file)
                       :filename (:name file)
                       :mtype "application/zip"
                       :description "Penpot export (*.zip)"
                       :uri (wapi/create-uri export-blob)}))))
               (rx/catch
                   (fn [err]
                     (rx/of {:type :error
                             :error (str err)
                             :file-id (:id file)}))))))))