SelectOpts for better clipboard and file selector options for image compression and OPFS

Author: functora

ghcjs/delivery-calculator/src/App/Jsm.hs

@@ -13,7 +13,7 @@ fetchBlobUris st = do
   vars <-
     forM blobUris $ \uri -> do
       var <- newEmptyMVar
-      Jsm.fetchUrlAsRfc2397 (Just 400000) uri
+      Jsm.fetchUrlAsRfc2397 uri
         $ liftIO
         . putMVar var
         . fmap (uri,)

ghcjs/delivery-calculator/src/App/Types.hs

@@ -176,9 +176,25 @@ newAsset = do
     either throw pure . decodeUtf8Strict . unTagged . htmlUid =<< newUid
   photo <-
     fmap
-      ( (#fieldPairValue . #fieldOpfsName .~ Just opfs)
-          . (#fieldPairValue . #fieldType .~ FieldTypeImage)
-          . (#fieldPairValue . #fieldOpts . #fieldOptsTruncateLimit .~ Nothing)
+      ( ( #fieldPairValue
+            . #fieldSelectOpts
+            . #selectOptsOpfsName
+            .~ Just opfs
+        )
+          . ( #fieldPairValue
+                . #fieldSelectOpts
+                . #selectOptsMaxSizeKb
+                .~ Just 400000
+            )
+          . ( #fieldPairValue
+                . #fieldType
+                .~ FieldTypeImage
+            )
+          . ( #fieldPairValue
+                . #fieldOpts
+                . #fieldOptsTruncateLimit
+                .~ Nothing
+            )
       )
       . newFieldPair "Photo"
       $ DynamicFieldText mempty

ghcjs/delivery-calculator/src/Main.hs

@@ -434,7 +434,7 @@ opfsRead sink st =
               . ix fieldIdx
               . #fieldPairValue
       when (field ^. #fieldType == FieldTypeImage)
-        $ whenJust (field ^. #fieldOpfsName)
+        $ whenJust (field ^. #fieldSelectOpts . #selectOptsOpfsName)
         $ \opfsName -> Jsm.opfsRead opfsName . flip whenJust $ \uri ->
           liftIO
             . sink

ghcjs/miso-functora/js/main.js

@@ -30,7 +30,7 @@ export async function insertStorage(key, value) {
   return await Preferences.set({ key: key, value: value });
 }
 
-export async function compressImage(maxSizeKb, prevImage) {
+export async function compressImage(prevImage, maxSizeKb) {
   let opts = { quality: 1 };
   if (maxSizeKb) {
     opts = {
@@ -50,12 +50,12 @@ export async function compressImage(maxSizeKb, prevImage) {
   return nextImage;
 }
 
-export async function selectClipboard(opfsName = null) {
+export async function selectClipboard(opts = {}) {
   const { value } = await Clipboard.read();
-  return await selectDataUrl(value, opfsName);
+  return await resolveDataUrl(value, opts);
 }
 
-export async function selectFile(file, opfsName = null) {
+export async function selectFile(file, opts = {}) {
   const value = await new Promise((resolve, reject) => {
     var fr = new FileReader();
     fr.onload = () => {
@@ -64,18 +64,22 @@ export async function selectFile(file, opfsName = null) {
     fr.onerror = reject;
     fr.readAsDataURL(file);
   });
-  return await selectDataUrl(value, opfsName);
+  return await resolveDataUrl(value, opts);
 }
 
-export async function selectDataUrl(value, opfsName = null) {
+export async function resolveDataUrl(value, opts = {}) {
   try {
     const { buffer: u8a, typeFull: mime } = dataUriToBuffer(value);
     let blob = new Blob([u8a], { type: mime });
     if (mime.startsWith("image")) {
-      blob = await compressImage(null, blob);
+      let maxSizeKb = null;
+      if (opts.maxSizeKb) {
+        maxSizeKb = opts.maxSizeKb;
+      }
+      blob = await compressImage(blob, maxSizeKb);
     }
-    if (opfsName) {
-      await opfsWrite(value, opfsName);
+    if (opts.opfsName) {
+      await opfsWrite(value, opts.opfsName);
     }
     return URL.createObjectURL(blob);
   } catch (e) {
@@ -102,7 +106,7 @@ export async function opfsRead(opfsName) {
     const handle = await root.getFileHandle(opfsName);
     const file = await handle.getFile();
     const uri = await file.text();
-    const res = await selectDataUrl(uri);
+    const res = await resolveDataUrl(uri);
     return res;
   } catch (e) {
     alert("OPFS read failure: " + e.toString() + " file: " + opfsName);
@@ -200,17 +204,16 @@ export function isNativePlatform() {
   return Capacitor.isNativePlatform();
 }
 
-export async function fetchUrlAsRfc2397(maxSizeKb, url) {
+export async function fetchUrlAsRfc2397(url) {
   const imgResp = await fetch(url);
   const imgBlob = await imgResp.blob();
-  const imgComp = await compressImage(maxSizeKb, imgBlob);
   const rfc2397 = await new Promise((resolve, reject) => {
     var fr = new FileReader();
     fr.onload = () => {
       resolve(fr.result);
     };
     fr.onerror = reject;
-    fr.readAsDataURL(imgComp);
+    fr.readAsDataURL(imgBlob);
   });
   const utf8Encode = new TextEncoder();
   const ab = utf8Encode.encode(rfc2397).buffer;

ghcjs/miso-functora/js/main.min.js

@@ -7,6 +7,8 @@ module Functora.Miso.Jsm.Generic
     openBrowserPage,
     enterOrEscapeBlur,
     insertStorage,
+    SelectOpts (..),
+    defSelectOpts,
     selectStorage,
     selectBarcode,
     selectClipboard,
@@ -152,17 +154,17 @@ selectBarcode after =
     $ after
     . fmap strip
 
-selectClipboard :: Maybe Unicode -> (Maybe Unicode -> JSM ()) -> JSM ()
-selectClipboard opfsName after = do
-  jopfsName <- JS.toJSVal opfsName
-  genericPromise @[JS.JSVal] @Unicode "selectClipboard" [jopfsName]
+selectClipboard :: SelectOpts -> (Maybe Unicode -> JSM ()) -> JSM ()
+selectClipboard opts after = do
+  jopts <- JS.toJSVal $ toJSON opts
+  genericPromise @[JS.JSVal] @Unicode "selectClipboard" [jopts]
     $ after
     . fmap strip
 
-selectFile :: Maybe Unicode -> JS.JSVal -> (Maybe Unicode -> JSM ()) -> JSM ()
-selectFile opfsName file after = do
-  jopfsName <- JS.toJSVal opfsName
-  genericPromise @[JS.JSVal] @Unicode "selectFile" [file, jopfsName]
+selectFile :: SelectOpts -> JS.JSVal -> (Maybe Unicode -> JSM ()) -> JSM ()
+selectFile opts file after = do
+  jopts <- JS.toJSVal $ toJSON opts
+  genericPromise @[JS.JSVal] @Unicode "selectFile" [file, jopts]
     $ after
     . fmap strip
 
@@ -251,11 +253,10 @@ saveFileThen onSuccess name mime bs = do
     Just str -> onSuccess str
 
 fetchUrlAsRfc2397 ::
-  Maybe Int ->
   Unicode ->
   (Maybe ByteString -> JSM ()) ->
   JSM ()
-fetchUrlAsRfc2397 maxSizeKb url after = do
+fetchUrlAsRfc2397 url after = do
   success <- JS.function $ \_ _ ->
     handleAny
       ( \e -> do
@@ -280,10 +281,6 @@ fetchUrlAsRfc2397 maxSizeKb url after = do
       alert $ "Failure, " <> inspect msg <> "!"
       after Nothing
   pkg <- getPkg
-  argv <-
-    sequence
-      [ JS.toJSVal maxSizeKb,
-        JS.toJSVal url
-      ]
+  argv <- sequence [JS.toJSVal url]
   prom <- pkg ^. JS.jsf ("fetchUrlAsRfc2397" :: Unicode) (argv :: [JS.JSVal])
   void $ prom ^. JS.js2 @Unicode "then" success failure

ghcjs/miso-functora/src/Functora/Miso/Jsm/Generic.hs

@@ -58,6 +58,8 @@ module Functora.Miso.Types
     themeCssFile,
     noopAll,
     noop,
+    SelectOpts (..),
+    defSelectOpts,
     module X,
   )
 where
@@ -128,7 +130,7 @@ data Field a f = Field
   { fieldType :: FieldType,
     fieldInput :: f Unicode,
     fieldOutput :: a,
-    fieldOpfsName :: Maybe Unicode,
+    fieldSelectOpts :: SelectOpts,
     fieldModalState :: OpenedOrClosed,
     fieldFocusState :: FocusedOrBlurred,
     fieldRequired :: Bool,
@@ -184,7 +186,7 @@ newField typ output newInput = do
       { fieldType = typ,
         fieldInput = input,
         fieldOutput = output,
-        fieldOpfsName = Nothing,
+        fieldSelectOpts = defSelectOpts,
         fieldModalState = Closed,
         fieldFocusState = Blurred,
         fieldRequired = False,
@@ -197,7 +199,7 @@ newFieldId typ viewer output =
     { fieldType = typ,
       fieldInput = Identity $ viewer output,
       fieldOutput = output,
-      fieldOpfsName = Nothing,
+      fieldSelectOpts = defSelectOpts,
       fieldModalState = Closed,
       fieldFocusState = Blurred,
       fieldRequired = False,
@@ -617,3 +619,17 @@ noop action event =
     . action
     . EffectUpdate
     $ pure ()
+
+data SelectOpts = SelectOpts
+  { selectOptsOpfsName :: Maybe Unicode,
+    selectOptsMaxSizeKb :: Maybe Int
+  }
+  deriving stock (Eq, Ord, Show, Data, Generic)
+  deriving (Binary, ToJSON, FromJSON) via GenericType SelectOpts
+
+defSelectOpts :: SelectOpts
+defSelectOpts =
+  SelectOpts
+    { selectOptsOpfsName = Nothing,
+      selectOptsMaxSizeKb = Nothing
+    }

ghcjs/miso-functora/src/Functora/Miso/Types.hs

@@ -343,7 +343,11 @@ field full@Full {fullArgs = args, fullParser = parser, fullViewer = viewer} opts
           else do
             file <- el JS.! ("files" :: Unicode) JS.!! 0
             Jsm.selectFile
-              (st ^? cloneTraversal optic . #fieldOpfsName . _Just)
+              ( fromMaybe defSelectOpts
+                  $ st
+                  ^? cloneTraversal optic
+                  . #fieldSelectOpts
+              )
               file
               $ \case
                 Nothing -> Jsm.popupText @Unicode "File is not selected!"
@@ -455,8 +459,10 @@ fieldIcon full opts = \case
   PasteWidget attrs ->
     fieldIconSimple opts Icon.IconPaste attrs
       . insertAction full
-      $ Jsm.selectClipboard
-        (st ^? cloneTraversal optic . #fieldOpfsName . _Just)
+      . Jsm.selectClipboard
+      $ fromMaybe
+        defSelectOpts
+        (st ^? cloneTraversal optic . #fieldSelectOpts)
   ScanQrWidget ->
     fieldIconSimple opts Icon.IconQrCode mempty
       $ insertAction full Jsm.selectBarcode