penpot/backend/src/app/rpc/commands/binfile.clj
2024-01-26 09:26:32 +01:00

1147 lines
40 KiB
Clojure

;; 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.rpc.commands.binfile
(:refer-clojure :exclude [assert])
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.features :as cfeat]
[app.common.files.defaults :as cfd]
[app.common.files.migrations :as fmg]
[app.common.files.validate :as fval]
[app.common.fressian :as fres]
[app.common.logging :as l]
[app.common.schema :as sm]
[app.common.spec :as us]
[app.common.types.file :as ctf]
[app.common.uuid :as uuid]
[app.config :as cf]
[app.db :as db]
[app.features.components-v2 :as feat.compv2]
[app.features.fdata :as feat.fdata]
[app.http.sse :as sse]
[app.loggers.audit :as-alias audit]
[app.loggers.webhooks :as-alias webhooks]
[app.media :as media]
[app.rpc :as-alias rpc]
[app.rpc.commands.files :as files]
[app.rpc.commands.projects :as projects]
[app.rpc.commands.teams :as teams]
[app.rpc.doc :as-alias doc]
[app.storage :as sto]
[app.storage.tmp :as tmp]
[app.tasks.file-gc]
[app.util.blob :as blob]
[app.util.pointer-map :as pmap]
[app.util.services :as sv]
[app.util.time :as dt]
[app.worker :as-alias wrk]
[clojure.set :as set]
[clojure.spec.alpha :as s]
[clojure.walk :as walk]
[cuerdas.core :as str]
[datoteka.io :as io]
[promesa.core :as p]
[promesa.util :as pu]
[ring.response :as rres]
[yetti.adapter :as yt])
(:import
com.github.luben.zstd.ZstdInputStream
com.github.luben.zstd.ZstdOutputStream
java.io.DataInputStream
java.io.DataOutputStream
java.io.InputStream
java.io.OutputStream))
(set! *warn-on-reflection* true)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DEFAULTS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Threshold in MiB when we pass from using
;; in-memory byte-array's to use temporal files.
(def temp-file-threshold
(* 1024 1024 2))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; LOW LEVEL STREAM IO API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def ^:const buffer-size (:xnio/buffer-size yt/defaults))
(def ^:const penpot-magic-number 800099563638710213)
(def ^:const max-object-size (* 1024 1024 100)) ; Only allow 100MiB max file size.
(def ^:dynamic *position* nil)
(defn get-mark
[id]
(case id
:header 1
:stream 2
:uuid 3
:label 4
:obj 5
(ex/raise :type :validation
:code :invalid-mark-id
:hint (format "invalid mark id %s" id))))
(defmacro assert
[expr hint]
`(when-not ~expr
(ex/raise :type :validation
:code :unexpected-condition
:hint ~hint)))
(defmacro assert-mark
[v type]
`(let [expected# (get-mark ~type)
val# (long ~v)]
(when (not= val# expected#)
(ex/raise :type :validation
:code :unexpected-mark
:hint (format "received mark %s, expected %s" val# expected#)))))
(defmacro assert-label
[expr label]
`(let [v# ~expr]
(when (not= v# ~label)
(ex/raise :type :assertion
:code :unexpected-label
:hint (format "received label %s, expected %s" v# ~label)))))
;; --- PRIMITIVE IO
(defn write-byte!
[^DataOutputStream output data]
(l/trace :fn "write-byte!" :data data :position @*position* ::l/sync? true)
(.writeByte output (byte data))
(swap! *position* inc))
(defn read-byte!
[^DataInputStream input]
(let [v (.readByte input)]
(l/trace :fn "read-byte!" :val v :position @*position* ::l/sync? true)
(swap! *position* inc)
v))
(defn write-long!
[^DataOutputStream output data]
(l/trace :fn "write-long!" :data data :position @*position* ::l/sync? true)
(.writeLong output (long data))
(swap! *position* + 8))
(defn read-long!
[^DataInputStream input]
(let [v (.readLong input)]
(l/trace :fn "read-long!" :val v :position @*position* ::l/sync? true)
(swap! *position* + 8)
v))
(defn write-bytes!
[^DataOutputStream output ^bytes data]
(let [size (alength data)]
(l/trace :fn "write-bytes!" :size size :position @*position* ::l/sync? true)
(.write output data 0 size)
(swap! *position* + size)))
(defn read-bytes!
[^InputStream input ^bytes buff]
(let [size (alength buff)
readed (.readNBytes input buff 0 size)]
(l/trace :fn "read-bytes!" :expected (alength buff) :readed readed :position @*position* ::l/sync? true)
(swap! *position* + readed)
readed))
;; --- COMPOSITE IO
(defn write-uuid!
[^DataOutputStream output id]
(l/trace :fn "write-uuid!" :position @*position* :WRITTEN? (.size output) ::l/sync? true)
(doto output
(write-byte! (get-mark :uuid))
(write-long! (uuid/get-word-high id))
(write-long! (uuid/get-word-low id))))
(defn read-uuid!
[^DataInputStream input]
(l/trace :fn "read-uuid!" :position @*position* ::l/sync? true)
(let [m (read-byte! input)]
(assert-mark m :uuid)
(let [a (read-long! input)
b (read-long! input)]
(uuid/custom a b))))
(defn write-obj!
[^DataOutputStream output data]
(l/trace :fn "write-obj!" :position @*position* ::l/sync? true)
(let [^bytes data (fres/encode data)]
(doto output
(write-byte! (get-mark :obj))
(write-long! (alength data))
(write-bytes! data))))
(defn read-obj!
[^DataInputStream input]
(l/trace :fn "read-obj!" :position @*position* ::l/sync? true)
(let [m (read-byte! input)]
(assert-mark m :obj)
(let [size (read-long! input)]
(assert (pos? size) "incorrect header size found on reading header")
(let [buff (byte-array size)]
(read-bytes! input buff)
(fres/decode buff)))))
(defn write-label!
[^DataOutputStream output label]
(l/trace :fn "write-label!" :label label :position @*position* ::l/sync? true)
(doto output
(write-byte! (get-mark :label))
(write-obj! label)))
(defn read-label!
[^DataInputStream input]
(l/trace :fn "read-label!" :position @*position* ::l/sync? true)
(let [m (read-byte! input)]
(assert-mark m :label)
(read-obj! input)))
(defn write-header!
[^OutputStream output version]
(l/trace :fn "write-header!"
:version version
:position @*position*
::l/sync? true)
(let [vers (-> version name (subs 1) parse-long)
output (io/data-output-stream output)]
(doto output
(write-byte! (get-mark :header))
(write-long! penpot-magic-number)
(write-long! vers))))
(defn read-header!
[^InputStream input]
(l/trace :fn "read-header!" :position @*position* ::l/sync? true)
(let [input (io/data-input-stream input)
mark (read-byte! input)
mnum (read-long! input)
vers (read-long! input)]
(when (or (not= mark (get-mark :header))
(not= mnum penpot-magic-number))
(ex/raise :type :validation
:code :invalid-penpot-file
:hint "invalid penpot file"))
(keyword (str "v" vers))))
(defn copy-stream!
[^OutputStream output ^InputStream input ^long size]
(let [written (io/copy! input output :size size)]
(l/trace :fn "copy-stream!" :position @*position* :size size :written written ::l/sync? true)
(swap! *position* + written)
written))
(defn write-stream!
[^DataOutputStream output stream size]
(l/trace :fn "write-stream!" :position @*position* ::l/sync? true :size size)
(doto output
(write-byte! (get-mark :stream))
(write-long! size))
(copy-stream! output stream size))
(defn read-stream!
[^DataInputStream input]
(l/trace :fn "read-stream!" :position @*position* ::l/sync? true)
(let [m (read-byte! input)
s (read-long! input)
p (tmp/tempfile :prefix "penpot.binfile.")]
(assert-mark m :stream)
(when (> s max-object-size)
(ex/raise :type :validation
:code :max-file-size-reached
:hint (str/ffmt "unable to import storage object with size % bytes" s)))
(if (> s temp-file-threshold)
(with-open [^OutputStream output (io/output-stream p)]
(let [readed (io/copy! input output :offset 0 :size s)]
(l/trace :fn "read-stream*!" :expected s :readed readed :position @*position* ::l/sync? true)
(swap! *position* + readed)
[s p]))
[s (io/read-as-bytes input :size s)])))
(defmacro assert-read-label!
[input expected-label]
`(let [readed# (read-label! ~input)
expected# ~expected-label]
(when (not= readed# expected#)
(ex/raise :type :validation
:code :unexpected-label
:hint (format "unexpected label found: %s, expected: %s" readed# expected#)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; --- HELPERS
(defn zstd-input-stream
^InputStream
[input]
(ZstdInputStream. ^InputStream input))
(defn zstd-output-stream
^OutputStream
[output & {:keys [level] :or {level 0}}]
(ZstdOutputStream. ^OutputStream output (int level)))
(defn- get-files
[cfg ids]
(db/run! cfg (fn [{:keys [::db/conn]}]
(let [sql (str "SELECT id FROM file "
" WHERE id = ANY(?) ")
ids (db/create-array conn "uuid" ids)]
(->> (db/exec! conn [sql ids])
(into [] (map :id))
(not-empty))))))
(defn- get-file
[cfg file-id]
(db/run! cfg (fn [{:keys [::db/conn] :as cfg}]
(binding [pmap/*load-fn* (partial feat.fdata/load-pointer cfg file-id)]
(some-> (db/get* conn :file {:id file-id} {::db/remove-deleted false})
(files/decode-row)
(update :data feat.fdata/process-pointers deref))))))
(defn- get-file-media
[{:keys [::db/pool]} {:keys [data id] :as file}]
(pu/with-open [conn (db/open pool)]
(let [ids (app.tasks.file-gc/collect-used-media data)
ids (db/create-array conn "uuid" ids)
sql (str "SELECT * FROM file_media_object WHERE id = ANY(?)")]
;; We assoc the file-id again to the file-media-object row
;; because there are cases that used objects refer to other
;; files and we need to ensure in the exportation process that
;; all ids matches
(->> (db/exec! conn [sql ids])
(mapv #(assoc % :file-id id))))))
(defn- get-file-thumbnails
"Return all file thumbnails for a given file."
[{:keys [::db/pool]} id]
(pu/with-open [conn (db/open pool)]
(let [sql "SELECT * FROM file_tagged_object_thumbnail WHERE file_id = ?"]
(->> (db/exec! conn [sql id])
(mapv #(dissoc % :file-id))))))
(def ^:private storage-object-id-xf
(comp
(mapcat (juxt :media-id :thumbnail-id))
(filter uuid?)))
(def ^:private sql:file-libraries
"WITH RECURSIVE libs AS (
SELECT fl.id
FROM file AS fl
JOIN file_library_rel AS flr ON (flr.library_file_id = fl.id)
WHERE flr.file_id = ANY(?)
UNION
SELECT fl.id
FROM file AS fl
JOIN file_library_rel AS flr ON (flr.library_file_id = fl.id)
JOIN libs AS l ON (flr.file_id = l.id)
)
SELECT DISTINCT l.id
FROM libs AS l")
(defn- get-libraries
[{:keys [::db/pool]} ids]
(pu/with-open [conn (db/open pool)]
(let [ids (db/create-array conn "uuid" ids)]
(map :id (db/exec! pool [sql:file-libraries ids])))))
(defn- get-library-relations
[cfg ids]
(db/run! cfg (fn [{:keys [::db/conn]}]
(let [ids (db/create-array conn "uuid" ids)
sql (str "SELECT flr.* FROM file_library_rel AS flr "
" WHERE flr.file_id = ANY(?)")]
(db/exec! conn [sql ids])))))
(defn- create-or-update-file!
[conn params]
(let [sql (str "INSERT INTO file (id, project_id, name, revn, is_shared, data, created_at, modified_at) "
"VALUES (?, ?, ?, ?, ?, ?, ?, ?) "
"ON CONFLICT (id) DO UPDATE SET data=?")]
(db/exec-one! conn [sql
(:id params)
(:project-id params)
(:name params)
(:revn params)
(:is-shared params)
(:data params)
(:created-at params)
(:modified-at params)
(:data params)])))
;; --- GENERAL PURPOSE DYNAMIC VARS
(def ^:dynamic *state* nil)
(def ^:dynamic *options* nil)
;; --- EXPORT WRITER
(defn- embed-file-assets
[data cfg file-id]
(letfn [(walk-map-form [form state]
(cond
(uuid? (:fill-color-ref-file form))
(do
(vswap! state conj [(:fill-color-ref-file form) :colors (:fill-color-ref-id form)])
(assoc form :fill-color-ref-file file-id))
(uuid? (:stroke-color-ref-file form))
(do
(vswap! state conj [(:stroke-color-ref-file form) :colors (:stroke-color-ref-id form)])
(assoc form :stroke-color-ref-file file-id))
(uuid? (:typography-ref-file form))
(do
(vswap! state conj [(:typography-ref-file form) :typographies (:typography-ref-id form)])
(assoc form :typography-ref-file file-id))
(uuid? (:component-file form))
(do
(vswap! state conj [(:component-file form) :components (:component-id form)])
(assoc form :component-file file-id))
:else
form))
(process-group-of-assets [data [lib-id items]]
;; NOTE: there is a possibility that shape refers to an
;; non-existant file because the file was removed. In this
;; case we just ignore the asset.
(if-let [lib (get-file cfg lib-id)]
(reduce (partial process-asset lib) data items)
data))
(process-asset [lib data [bucket asset-id]]
(let [asset (get-in lib [:data bucket asset-id])
;; Add a special case for colors that need to have
;; correctly set the :file-id prop (pending of the
;; refactor that will remove it).
asset (cond-> asset
(= bucket :colors) (assoc :file-id file-id))]
(update data bucket assoc asset-id asset)))]
(let [assets (volatile! [])]
(walk/postwalk #(cond-> % (map? %) (walk-map-form assets)) data)
(->> (deref assets)
(filter #(as-> (first %) $ (and (uuid? $) (not= $ file-id))))
(d/group-by first rest)
(reduce (partial process-group-of-assets) data)))))
(defmulti write-export ::version)
(defmulti write-section ::section)
(s/def ::output io/output-stream?)
(s/def ::file-ids (s/every ::us/uuid :kind vector? :min-count 1))
(s/def ::include-libraries? (s/nilable ::us/boolean))
(s/def ::embed-assets? (s/nilable ::us/boolean))
(s/def ::write-export-options
(s/keys :req [::db/pool ::sto/storage ::output ::file-ids]
:opt [::include-libraries? ::embed-assets?]))
(defn write-export!
"Do the exportation of a specified file in custom penpot binary
format. There are some options available for customize the output:
`::include-libraries?`: additionally to the specified file, all the
linked libraries also will be included (including transitive
dependencies).
`::embed-assets?`: instead of including the libraries, embed in the
same file library all assets used from external libraries."
[{:keys [::include-libraries? ::embed-assets?] :as options}]
(us/assert! ::write-export-options options)
(us/verify!
:expr (not (and include-libraries? embed-assets?))
:hint "the `include-libraries?` and `embed-assets?` are mutally excluding options")
(write-export options))
(defmethod write-export :default
[{:keys [::output] :as options}]
(write-header! output :v1)
(pu/with-open [output (zstd-output-stream output :level 12)
output (io/data-output-stream output)]
(binding [*state* (volatile! {})]
(run! (fn [section]
(l/dbg :hint "write section" :section section ::l/sync? true)
(write-label! output section)
(let [options (-> options
(assoc ::output output)
(assoc ::section section))]
(binding [*options* options]
(write-section options))))
[:v1/metadata :v1/files :v1/rels :v1/sobjects]))))
(defmethod write-section :v1/metadata
[{:keys [::output ::file-ids ::include-libraries?] :as cfg}]
(if-let [fids (get-files cfg file-ids)]
(let [lids (when include-libraries?
(get-libraries cfg file-ids))
ids (into fids lids)]
(write-obj! output {:version cf/version :files ids})
(vswap! *state* assoc :files ids))
(ex/raise :type :not-found
:code :files-not-found
:hint "unable to retrieve files for export")))
(defmethod write-section :v1/files
[{:keys [::output ::embed-assets? ::include-libraries?] :as cfg}]
;; Initialize SIDS with empty vector
(vswap! *state* assoc :sids [])
(doseq [file-id (-> *state* deref :files)]
(let [detach? (and (not embed-assets?) (not include-libraries?))
thumbnails (get-file-thumbnails cfg file-id)
file (cond-> (get-file cfg file-id)
detach?
(-> (ctf/detach-external-references file-id)
(dissoc :libraries))
embed-assets?
(update :data embed-file-assets cfg file-id)
:always
(assoc :thumbnails thumbnails))
media (get-file-media cfg file)]
(l/dbg :hint "write penpot file"
:id (str file-id)
:name (:name file)
:thumbnails (count thumbnails)
:features (:features file)
:media (count media)
::l/sync? true)
(doseq [item media]
(l/dbg :hint "write penpot file media object" :id (:id item) ::l/sync? true))
(doseq [item thumbnails]
(l/dbg :hint "write penpot file object thumbnail" :media-id (str (:media-id item)) ::l/sync? true))
(doto output
(write-obj! file)
(write-obj! media))
(vswap! *state* update :sids into storage-object-id-xf media)
(vswap! *state* update :sids into storage-object-id-xf thumbnails))))
(defmethod write-section :v1/rels
[{:keys [::output ::include-libraries?] :as cfg}]
(let [ids (-> *state* deref :files)
rels (when include-libraries?
(get-library-relations cfg ids))]
(l/dbg :hint "found rels" :total (count rels) ::l/sync? true)
(write-obj! output rels)))
(defmethod write-section :v1/sobjects
[{:keys [::sto/storage ::output]}]
(let [sids (-> *state* deref :sids)
storage (media/configure-assets-storage storage)]
(l/dbg :hint "found sobjects"
:items (count sids)
::l/sync? true)
;; Write all collected storage objects
(write-obj! output sids)
(doseq [id sids]
(let [{:keys [size] :as obj} (sto/get-object storage id)]
(l/dbg :hint "write sobject" :id (str id) ::l/sync? true)
(doto output
(write-uuid! id)
(write-obj! (meta obj)))
(pu/with-open [stream (sto/get-object-data storage obj)]
(let [written (write-stream! output stream size)]
(when (not= written size)
(ex/raise :type :validation
:code :mismatch-readed-size
:hint (str/ffmt "found unexpected object size; size=% written=%" size written)))))))))
;; --- EXPORT READER
(declare lookup-index)
(declare update-index)
(declare relink-media)
(declare relink-colors)
(declare relink-shapes)
(defmulti read-import ::version)
(defmulti read-section ::section)
(s/def ::profile-id ::us/uuid)
(s/def ::project-id ::us/uuid)
(s/def ::input io/input-stream?)
(s/def ::overwrite? (s/nilable ::us/boolean))
(s/def ::ignore-index-errors? (s/nilable ::us/boolean))
;; FIXME: replace with schema
(s/def ::read-import-options
(s/keys :req [::db/pool ::sto/storage ::project-id ::profile-id ::input]
:opt [::overwrite? ::ignore-index-errors?]))
(defn read-import!
"Do the importation of the specified resource in penpot custom binary
format. There are some options for customize the importation
behavior:
`::overwrite?`: if true, instead of creating new files and remapping id references,
it reuses all ids and updates existing objects; defaults to `false`.
`::ignore-index-errors?`: if true, do not fail on index lookup errors, can
happen with broken files; defaults to: `false`.
"
[{:keys [::input ::timestamp] :or {timestamp (dt/now)} :as options}]
(us/verify! ::read-import-options options)
(let [version (read-header! input)]
(read-import (assoc options ::version version ::timestamp timestamp))))
(defn- read-import-v1
[{:keys [::db/conn ::project-id ::profile-id ::input] :as options}]
(db/exec-one! conn ["SET idle_in_transaction_session_timeout = 0"])
(db/exec-one! conn ["SET CONSTRAINTS ALL DEFERRED"])
(pu/with-open [input (zstd-input-stream input)
input (io/data-input-stream input)]
(binding [*state* (volatile! {:media [] :index {}})]
(let [team (teams/get-team conn
:profile-id profile-id
:project-id project-id)
validate? (contains? cf/flags :file-validation)
features (cfeat/get-team-enabled-features cf/flags team)]
(sse/tap {:type :import-progress
:section :read-import})
;; Process all sections
(run! (fn [section]
(l/dbg :hint "reading section" :section section ::l/sync? true)
(assert-read-label! input section)
(let [options (-> options
(assoc ::enabled-features features)
(assoc ::section section)
(assoc ::input input))]
(binding [*options* options]
(sse/tap {:type :import-progress
:section section})
(read-section options))))
[:v1/metadata :v1/files :v1/rels :v1/sobjects])
;; Run all pending migrations
(doseq [[feature file-id] (-> *state* deref :pending-to-migrate)]
(case feature
"components/v2"
(feat.compv2/migrate-file! options file-id
:validate? validate?)
"fdata/shape-data-type"
nil
(ex/raise :type :internal
:code :no-migration-defined
:hint (str/ffmt "no migation for feature '%' on file importation" feature)
:feature feature)))
;; Knowing that the ids of the created files are in index,
;; just lookup them and return it as a set
(let [files (-> *state* deref :files)]
(into #{} (keep #(get-in @*state* [:index %])) files))))))
(defmethod read-import :v1
[options]
(db/tx-run! options read-import-v1))
(defmethod read-section :v1/metadata
[{:keys [::input]}]
(let [{:keys [version files]} (read-obj! input)]
(l/dbg :hint "metadata readed"
:version (:full version)
:files (mapv str files)
::l/sync? true)
(vswap! *state* update :index update-index files)
(vswap! *state* assoc :version version :files files)))
(defn- get-remaped-thumbnails
[thumbnails file-id]
(mapv (fn [thumbnail]
(-> thumbnail
(assoc :file-id file-id)
(update :object-id #(str/replace-first % #"^(.*?)/" (str file-id "/")))))
thumbnails))
(defn- process-file
[{:keys [id] :as file}]
(-> file
(update :data (fn [fdata]
(-> fdata
(assoc :id id)
(dissoc :recent-colors)
(cond-> (> (:version fdata) cfd/version)
(assoc :version cfd/version))
;; FIXME: We're temporarily activating all
;; migrations because a problem in the
;; environments messed up with the version
;; numbers When this problem is fixed delete
;; the following line
(cond-> (> (:version fdata) 22)
(assoc :version 22)))))
(fmg/migrate-file)
(update :data (fn [fdata]
(-> fdata
(update :pages-index relink-shapes)
(update :components relink-shapes)
(update :media relink-media)
(update :colors relink-colors)
(d/without-nils))))))
(defmethod read-section :v1/files
[{:keys [::db/conn ::input ::project-id ::enabled-features ::timestamp ::overwrite? ::name] :as system}]
(doseq [[idx expected-file-id] (d/enumerate (-> *state* deref :files))]
(let [file (read-obj! input)
media (read-obj! input)
file-id (:id file)
file-id' (lookup-index file-id)
thumbnails (:thumbnails file)]
(when (not= file-id expected-file-id)
(ex/raise :type :validation
:code :inconsistent-penpot-file
:found-id file-id
:expected-id expected-file-id
:hint "the penpot file seems corrupt, found unexpected uuid (file-id)"))
(l/dbg :hint "processing file"
:id (str file-id)
:features (:features file)
:version (-> file :data :version)
:media (count media)
:thumbnails (count thumbnails)
::l/sync? true)
(when (seq thumbnails)
(let [thumbnails (get-remaped-thumbnails thumbnails file-id')]
(l/dbg :hint "updated index with thumbnails" :total (count thumbnails) ::l/sync? true)
(vswap! *state* update :thumbnails (fnil into []) thumbnails)))
(when (seq media)
;; Update index with media
(l/dbg :hint "update index with media" :total (count media) ::l/sync? true)
(vswap! *state* update :index update-index (map :id media))
;; Store file media for later insertion
(l/dbg :hint "update media references" ::l/sync? true)
(vswap! *state* update :media into (map #(update % :id lookup-index)) media))
(let [file (-> file
(assoc :id file-id')
(cond-> (and (= idx 0) (some? name))
(assoc :name name))
(process-file))
;; All features that are enabled and requires explicit migration are
;; added to the state for a posterior migration step.
_ (doseq [feature (-> enabled-features
(set/difference cfeat/no-migration-features)
(set/difference (:features file)))]
(vswap! *state* update :pending-to-migrate (fnil conj []) [feature file-id']))
file (-> file
(assoc :project-id project-id)
(assoc :created-at timestamp)
(assoc :modified-at timestamp)
(dissoc :thumbnails)
(update :features
(fn [features]
(let [features (cfeat/check-supported-features! features)]
(-> enabled-features
(set/difference cfeat/frontend-only-features)
(set/union features))))))
_ (when (contains? cf/flags :file-schema-validation)
(fval/validate-file-schema! file))
_ (when (contains? cf/flags :soft-file-schema-validation)
(let [result (ex/try! (fval/validate-file-schema! file))]
(when (ex/exception? result)
(l/error :hint "file schema validation error" :cause result))))
file (if (contains? (:features file) "fdata/objects-map")
(feat.fdata/enable-objects-map file)
file)
file (if (contains? (:features file) "fdata/pointer-map")
(binding [pmap/*tracked* (pmap/create-tracked)]
(let [file (feat.fdata/enable-pointer-map file)]
(feat.fdata/persist-pointers! system file-id')
file))
file)
file (-> file
(update :features #(db/create-array conn "text" %))
(update :data blob/encode))]
(l/dbg :hint "create file" :id (str file-id') ::l/sync? true)
(if overwrite?
(create-or-update-file! conn file)
(db/insert! conn :file file))
(when overwrite?
(db/delete! conn :file-thumbnail {:file-id file-id'}))
file-id'))))
(defmethod read-section :v1/rels
[{:keys [::db/conn ::input ::timestamp]}]
(let [rels (read-obj! input)
ids (into #{} (-> *state* deref :files))]
;; Insert all file relations
(doseq [{:keys [library-file-id] :as rel} rels]
(let [rel (-> rel
(assoc :synced-at timestamp)
(update :file-id lookup-index)
(update :library-file-id lookup-index))]
(if (contains? ids library-file-id)
(do
(l/dbg :hint "create file library link"
:file-id (:file-id rel)
:lib-id (:library-file-id rel)
::l/sync? true)
(db/insert! conn :file-library-rel rel))
(l/warn :hint "ignoring file library link"
:file-id (:file-id rel)
:lib-id (:library-file-id rel)
::l/sync? true))))))
(defmethod read-section :v1/sobjects
[{:keys [::sto/storage ::db/conn ::input ::overwrite? ::timestamp]}]
(let [storage (media/configure-assets-storage storage)
ids (read-obj! input)
thumb? (into #{} (map :media-id) (:thumbnails @*state*))]
(doseq [expected-storage-id ids]
(let [id (read-uuid! input)
mdata (read-obj! input)]
(when (not= id expected-storage-id)
(ex/raise :type :validation
:code :inconsistent-penpot-file
:hint "the penpot file seems corrupt, found unexpected uuid (storage-object-id)"))
(l/dbg :hint "readed storage object" :id (str id) ::l/sync? true)
(let [[size resource] (read-stream! input)
hash (sto/calculate-hash resource)
content (-> (sto/content resource size)
(sto/wrap-with-hash hash))
params (-> mdata
(assoc ::sto/content content)
(assoc ::sto/deduplicate? true)
(assoc ::sto/touched-at timestamp))
params (if (thumb? id)
(assoc params :bucket "file-object-thumbnail")
(assoc params :bucket "file-media-object"))
sobject (sto/put-object! storage params)]
(l/dbg :hint "persisted storage object"
:old-id (str id)
:new-id (str (:id sobject))
:is-thumbnail (boolean (thumb? id))
::l/sync? true)
(vswap! *state* update :index assoc id (:id sobject)))))
(doseq [item (:media @*state*)]
(l/dbg :hint "inserting file media object"
:id (str (:id item))
:file-id (str (:file-id item))
::l/sync? true)
(let [file-id (lookup-index (:file-id item))]
(if (= file-id (:file-id item))
(l/warn :hint "ignoring file media object" :file-id (str file-id) ::l/sync? true)
(db/insert! conn :file-media-object
(-> item
(assoc :file-id file-id)
(d/update-when :media-id lookup-index)
(d/update-when :thumbnail-id lookup-index))
{::db/on-conflict-do-nothing? overwrite?}))))
(doseq [item (:thumbnails @*state*)]
(let [item (update item :media-id lookup-index)]
(l/dbg :hint "inserting file object thumbnail"
:file-id (str (:file-id item))
:media-id (str (:media-id item))
:object-id (:object-id item)
::l/sync? true)
(db/insert! conn :file-tagged-object-thumbnail item
{::db/on-conflict-do-nothing? overwrite?})))))
(defn- lookup-index
[id]
(let [val (get-in @*state* [:index id])]
(l/trc :fn "lookup-index" :id id :val val ::l/sync? true)
(when (and (not (::ignore-index-errors? *options*)) (not val))
(ex/raise :type :validation
:code :incomplete-index
:hint "looks like index has missing data"))
(or val id)))
(defn- update-index
[index coll]
(loop [items (seq coll)
index index]
(if-let [id (first items)]
(let [new-id (if (::overwrite? *options*) id (uuid/next))]
(l/trc :fn "update-index" :id id :new-id new-id ::l/sync? true)
(recur (rest items)
(assoc index id new-id)))
index)))
(defn- relink-shapes
"A function responsible to analyze all file data and
replace the old :component-file reference with the new
ones, using the provided file-index."
[data]
(letfn [(process-map-form [form]
(cond-> form
;; Relink image shapes
(and (map? (:metadata form))
(= :image (:type form)))
(update-in [:metadata :id] lookup-index)
;; Relink paths with fill image
(map? (:fill-image form))
(update-in [:fill-image :id] lookup-index)
;; This covers old shapes and the new :fills.
(uuid? (:fill-color-ref-file form))
(update :fill-color-ref-file lookup-index)
;; This covers the old shapes and the new :strokes
(uuid? (:storage-color-ref-file form))
(update :stroke-color-ref-file lookup-index)
;; This covers all text shapes that have typography referenced
(uuid? (:typography-ref-file form))
(update :typography-ref-file lookup-index)
;; This covers the component instance links
(uuid? (:component-file form))
(update :component-file lookup-index)
;; This covers the shadows and grids (they have directly
;; the :file-id prop)
(uuid? (:file-id form))
(update :file-id lookup-index)))]
(walk/postwalk (fn [form]
(if (map? form)
(try
(process-map-form form)
(catch Throwable cause
(l/warn :hint "failed form" :form (pr-str form) ::l/sync? true)
(throw cause)))
form))
data)))
(defn- relink-media
"A function responsible of process the :media attr of file data and
remap the old ids with the new ones."
[media]
(reduce-kv (fn [res k v]
(let [id (lookup-index k)]
(if (uuid? id)
(-> res
(assoc id (assoc v :id id))
(dissoc k))
res)))
media
media))
(defn- relink-colors
"A function responsible of process the :colors attr of file data and
remap the old ids with the new ones."
[colors]
(reduce-kv (fn [res k v]
(if (:image v)
(update-in res [k :image :id] lookup-index)
res))
colors
colors))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HIGH LEVEL API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn export!
[cfg output]
(let [id (uuid/next)
tp (dt/tpoint)
ab (volatile! false)
cs (volatile! nil)]
(try
(l/info :hint "start exportation" :export-id (str id))
(pu/with-open [output (io/output-stream output)]
(binding [*position* (atom 0)]
(write-export! (assoc cfg ::output output))))
(catch java.io.IOException _cause
;; Do nothing, EOF means client closes connection abruptly
(vreset! ab true)
nil)
(catch Throwable cause
(vreset! cs cause)
(vreset! ab true)
(throw cause))
(finally
(l/info :hint "exportation finished" :export-id (str id)
:elapsed (str (inst-ms (tp)) "ms")
:aborted @ab
:cause @cs)))))
(defn export-to-tmpfile!
[cfg]
(let [path (tmp/tempfile :prefix "penpot.export.")]
(pu/with-open [output (io/output-stream path)]
(export! cfg output)
path)))
(defn import!
[{:keys [::input] :as cfg}]
(let [id (uuid/next)
tp (dt/tpoint)
cs (volatile! nil)]
(l/info :hint "import: started" :id (str id))
(try
(binding [*position* (atom 0)]
(pu/with-open [input (io/input-stream input)]
(read-import! (assoc cfg ::input input))))
(catch Throwable cause
(vreset! cs cause)
(throw cause))
(finally
(l/info :hint "import: terminated"
:id (str id)
:elapsed (dt/format-duration (tp))
:error? (some? @cs))))))
;; --- Command: export-binfile
(def ^:private
schema:export-binfile
(sm/define
[:map {:title "export-binfile"}
[:file-id ::sm/uuid]
[:include-libraries? :boolean]
[:embed-assets? :boolean]]))
(sv/defmethod ::export-binfile
"Export a penpot file in a binary format."
{::doc/added "1.15"
::webhooks/event? true
::sm/result schema:export-binfile}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id file-id include-libraries? embed-assets?] :as params}]
(files/check-read-permissions! pool profile-id file-id)
(fn [_]
{::rres/status 200
::rres/headers {"content-type" "application/octet-stream"}
::rres/body (reify rres/StreamableResponseBody
(-write-body-to-stream [_ _ output-stream]
(-> cfg
(assoc ::file-ids [file-id])
(assoc ::embed-assets? embed-assets?)
(assoc ::include-libraries? include-libraries?)
(export! output-stream))))}))
;; --- Command: import-binfile
(def ^:private
schema:import-binfile
(sm/define
[:map {:title "import-binfile"}
[:name :string]
[:project-id ::sm/uuid]
[:file ::media/upload]]))
(declare ^:private import-binfile)
(sv/defmethod ::import-binfile
"Import a penpot file in a binary format."
{::doc/added "1.15"
::webhooks/event? true
::sse/stream? true
::sm/params schema:import-binfile}
[{:keys [::db/pool] :as cfg} {:keys [::rpc/profile-id name project-id file] :as params}]
(projects/check-read-permissions! pool profile-id project-id)
(let [params (-> cfg
(assoc ::input (:path file))
(assoc ::project-id project-id)
(assoc ::profile-id profile-id)
(assoc ::name name)
(assoc ::ignore-index-errors? true))]
(with-meta
(sse/response #(import-binfile params))
{::audit/props {:file nil}})))
(defn- import-binfile
[{:keys [::wrk/executor ::project-id] :as params}]
(db/tx-run! params
(fn [{:keys [::db/conn] :as params}]
;; NOTE: the importation process performs some operations that
;; are not very friendly with virtual threads, and for avoid
;; unexpected blocking of other concurrent operations we
;; dispatch that operation to a dedicated executor.
(let [result (p/thread-call executor (partial import! params))]
(db/update! conn :project
{:modified-at (dt/now)}
{:id project-id})
(deref result)))))