penpot/frontend/src/app/util/webapi.cljs

370 lines
10 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.util.webapi
"HTML5 web api helpers."
(:require
[app.common.data :as d]
[app.common.exceptions :as ex]
[app.common.logging :as log]
[app.util.globals :as globals]
[app.util.object :as obj]
[beicon.v2.core :as rx]
[cuerdas.core :as str]
[promesa.core :as p]))
(log/set-level! :warn)
(defn- file-reader
[f]
(rx/create
(fn [subs]
(let [reader (js/FileReader.)]
(obj/set! reader "onload" #(do (rx/push! subs (.-result ^js reader))
(rx/end! subs)))
(obj/set! reader "onerror" #(rx/error! subs %))
(obj/set! reader "onabort" #(rx/error! subs (ex/error :type :internal
:code :abort
:hint "operation aborted")))
(f reader)
(fn []
(.abort ^js reader))))))
(defn read-file-as-text
[file]
(file-reader #(.readAsText %1 file)))
(defn read-file-as-array-buffer
[file]
(file-reader #(.readAsArrayBuffer %1 file)))
(defn read-file-as-data-url
[file]
(file-reader #(.readAsDataURL ^js %1 file)))
(defn blob?
[v]
(instance? js/Blob v))
(defn create-blob
"Create a blob from content."
([content]
(create-blob content "application/octet-stream"))
([content mtype]
(js/Blob. #js [content] #js {:type mtype})))
(defn create-blob-from-canvas
([canvas]
(create-blob-from-canvas canvas nil))
([canvas options]
(if (obj/in? canvas "convertToBlob")
(.convertToBlob canvas options)
(p/create (fn [resolve _] (.toBlob #(resolve %) canvas options))))))
(defn revoke-uri
[url]
(when ^boolean (str/starts-with? url "blob:")
(js/URL.revokeObjectURL url)))
(defn create-uri
"Create a url from blob."
[b]
(assert (blob? b) "invalid arguments")
(js/URL.createObjectURL b))
(defn data-uri?
[s]
(str/starts-with? s "data:"))
(defn data-uri->blob
[data-uri]
(let [[mtype b64-data] (str/split data-uri ";base64," 2)
mtype (subs mtype (inc (str/index-of mtype ":")))
decoded (.atob js/window b64-data)
size (.-length ^js decoded)
content (js/Uint8Array. size)]
(loop [i 0]
(when (< i size)
(aset content i (.charCodeAt ^js decoded i))
(recur (inc i))))
(create-blob content mtype)))
(defn get-current-selected-text
[]
(.. js/window getSelection toString))
(defn write-to-clipboard
[data]
(assert (string? data) "`data` should be string")
(let [cboard (unchecked-get js/navigator "clipboard")]
(.writeText ^js cboard data)))
(defn write-to-clipboard-promise
[mimetype promise]
(let [cboard (unchecked-get js/navigator "clipboard")
data (js/ClipboardItem.
(-> (obj/create)
(obj/set! mimetype promise)))]
(.write ^js cboard #js [data])))
(defn read-from-clipboard
[]
(try
(let [cboard (unchecked-get js/navigator "clipboard")]
(if (.-readText ^js cboard)
(rx/from (.readText ^js cboard))
(rx/throw (ex-info "This browser does not implement read from clipboard protocol"
{:not-implemented true}))))
(catch :default cause
(rx/throw cause))))
(defn read-image-from-clipboard
[]
(try
(let [cboard (unchecked-get js/navigator "clipboard")
read-item (fn [item]
(let [img-type (->> (.-types ^js item)
(d/seek #(str/starts-with? % "image/")))]
(if img-type
(rx/from (.getType ^js item img-type))
(rx/empty))))]
(->> (rx/from (.read ^js cboard)) ;; Get a stream of item lists
(rx/mapcat identity) ;; Convert each item into an emission
(rx/switch-map read-item)))
(catch :default cause
(rx/throw cause))))
(defn read-from-paste-event
[event]
(let [target (.-target ^js event)]
(when (and (not (.-isContentEditable ^js target)) ;; ignore when pasting into
(not= (.-tagName ^js target) "INPUT")) ;; an editable control
(.. ^js event getBrowserEvent -clipboardData))))
(defn extract-html-text
[clipboard-data]
(.getData clipboard-data "text/html"))
(defn extract-text
[clipboard-data]
(.getData clipboard-data "text"))
(defn extract-images
"Get image files from clipboard data. Returns a native js array."
[clipboard-data]
(let [files (obj/into-array (.-files ^js clipboard-data))]
(.filter ^js files #(str/starts-with? (obj/get % "type") "image/"))))
(defn create-canvas-element
[width height]
(let [canvas (.createElement js/document "canvas")]
(obj/set! canvas "width" width)
(obj/set! canvas "height" height)
canvas))
(defn create-offscreen-canvas
[width height]
(if (obj/in? js/window "OffscreenCanvas")
(js/OffscreenCanvas. width height)
(create-canvas-element width height)))
(defn create-image-bitmap
([image]
(js/createImageBitmap image))
([image options]
(js/createImageBitmap image options)))
(defn create-image
([src]
(create-image src nil nil))
([src width height]
(p/create
(fn [resolve reject]
(let [img (.createElement js/document "img")]
(when-not (nil? width)
(obj/set! img "width" width))
(when-not (nil? height)
(obj/set! img "height" height))
(obj/set! img "src" src)
(obj/set! img "onload" #(resolve img))
(obj/set! img "onerror" reject))))))
;; Why this? Because as described in https://bugs.chromium.org/p/chromium/issues/detail?id=1463435
;; the createImageBitmap seems to apply premultiplied alpha multiples times on the same image
;; which results in harsh borders around text being rendered. This is a workaround to avoid this issue.
(defn create-image-bitmap-with-workaround
([image]
(create-image-bitmap-with-workaround image nil))
([^js image options]
(let [offscreen-canvas (create-offscreen-canvas (.-width image) (.-height image))
offscreen-context (.getContext offscreen-canvas "2d")]
(.drawImage offscreen-context image 0 0)
(create-image-bitmap offscreen-canvas options))))
(defn request-fullscreen
[el]
(cond
(obj/in? el "requestFullscreen")
(.requestFullscreen el)
(obj/in? el "webkitRequestFullscreen")
(.webkitRequestFullscreen el)
:else
(do
(log/error :msg "Seems like the current browser does not support fullscreen api.")
false)))
(defn exit-fullscreen
[]
(cond
(obj/in? js/document "exitFullscreen")
(.exitFullscreen js/document)
(obj/in? js/document "webkitExitFullscreen")
(.webkitExitFullscreen js/document)
:else
(do
(log/error :msg "Seems like the current browser does not support fullscreen api.")
false)))
(defn observe-resize
[node]
(rx/create
(fn [subs]
(let [obs (js/ResizeObserver.
(fn [entries _]
(rx/push! subs entries)))]
(.observe ^js obs node)
(fn []
(.disconnect ^js obs))))))
(defn empty-png-size*
[width height]
(p/create
(fn [resolve reject]
(try
(let [canvas (.createElement js/document "canvas")
_ (set! (.-width canvas) width)
_ (set! (.-height canvas) height)
_ (set! (.-background canvas) "white")
canvas-context (.getContext canvas "2d")]
(.fillRect canvas-context 0 0 width height)
(.toBlob canvas
(fn [blob]
(->> (read-file-as-data-url blob)
(rx/catch (fn [err] (reject err)))
(rx/subs! (fn [result] (resolve result)))))))
(catch :default e (reject e))))))
(def empty-png-size (memoize empty-png-size*))
(defn create-range
[]
(let [document globals/document]
(.createRange document)))
(defn select-contents!
[range node]
(when (and range node)
(.selectNodeContents range node))
range)
(defn select-all-children!
[^js selection ^js node]
(.selectAllChildren selection node))
(defn get-selection
"Only returns valid selection"
[]
(when-let [document globals/document]
(let [selection (.getSelection document)]
(when (not= (.-type selection) "None")
selection))))
(defn get-anchor-node
[^js selection]
(when selection
(.-anchorNode selection)))
(defn get-anchor-offset
[^js selection]
(when selection
(.-anchorOffset selection)))
(defn remove-all-ranges!
[^js sel]
(.removeAllRanges sel)
sel)
(defn add-range!
[^js sel ^js range]
(.addRange sel range)
sel)
(defn collapse-end!
[^js sel]
(.collapseToEnd sel)
sel)
(defn set-cursor!
([^js node]
(set-cursor! node 0))
([^js node offset]
(when node
(let [child-nodes (.-childNodes node)
sel (get-selection)
r (create-range)]
(if (= (.-length child-nodes) 0)
(do (.setStart r node offset)
(.setEnd r node offset)
(remove-all-ranges! sel)
(add-range! sel r))
(let [text-node (aget child-nodes 0)]
(.setStart r text-node offset)
(.setEnd r text-node offset)
(remove-all-ranges! sel)
(add-range! sel r)))))))
(defn set-cursor-before!
[^js node]
(set-cursor! node 1))
(defn set-cursor-after!
[^js node]
(let [child-nodes (.-childNodes node)
first-child (aget child-nodes 0)
offset (if first-child (.-length first-child) 0)]
(set-cursor! node offset)))
(defn get-range
[^js selection idx]
(.getRangeAt selection idx))
(defn range-start-container
[^js range]
(when range
(.-startContainer range)))
(defn range-start-offset
[^js range]
(when range
(.-startOffset range)))
(defn range-end-container
[^js range]
(when range
(.-endContainer range)))
(defn range-end-offset
[^js range]
(when range
(.-endOffset range)))