field image file input

Author: functora

ghcjs/delivery-calculator/src/Main.hs

@@ -379,7 +379,10 @@ syncInputs st = do
       elExist <- ghcjsPure $ JS.isTruthy el
       when elExist $ do
         elActive <- JS.strictEqual el act
-        unless elActive $ el ^. JS.jss ("value" :: Unicode) (txt ^. #uniqueValue)
+        typ <- (el ! ("type" :: Unicode)) >>= JS.fromJSVal
+        unless (elActive || typ == Just ("file" :: Unicode))
+          $ el
+          ^. JS.jss ("value" :: Unicode) (txt ^. #uniqueValue)
       pure txt
 
 evalModel :: (MonadThrow m, MonadUnliftIO m) => Model -> m (Model -> Model)

ghcjs/miso-functora/js/main.js

@@ -30,20 +30,25 @@ export async function insertStorage(key, value) {
   return await Preferences.set({ key: key, value: value });
 }
 
+export async function compressImage(quality, prevImage) {
+  const nextImage = await new Promise((resolve, reject) => {
+    new Compressor(prevImage, {
+      quality: quality,
+      mimeType: "image/jpeg",
+      success: resolve,
+      error: reject,
+    });
+  });
+  return nextImage;
+}
+
 export async function selectClipboard() {
   const { value } = await Clipboard.read();
   try {
     const { buffer: u8a, typeFull: mime } = dataUriToBuffer(value);
     let blob = new Blob([u8a], { type: mime });
     if (mime.startsWith("image")) {
-      blob = await new Promise((resolve, reject) => {
-        new Compressor(blob, {
-          quality: 0.1,
-          mimeType: "image/jpeg",
-          success: resolve,
-          error: reject,
-        });
-      });
+      blob = await compressImage(1, blob);
     }
     return URL.createObjectURL(blob);
   } catch (e) {
@@ -118,13 +123,14 @@ export function isNativePlatform() {
 export async function fetchUrlAsRfc2397(url) {
   const imgResp = await fetch(url);
   const imgBlob = await imgResp.blob();
+  const imgComp = await compressImage(0.2, imgBlob);
   const rfc2397 = await new Promise((resolve, reject) => {
     var fr = new FileReader();
     fr.onload = () => {
       resolve(fr.result);
     };
     fr.onerror = reject;
-    fr.readAsDataURL(imgBlob);
+    fr.readAsDataURL(imgComp);
   });
   const utf8Encode = new TextEncoder();
   const ab = utf8Encode.encode(rfc2397).buffer;

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

@@ -25,6 +25,7 @@ import qualified Functora.Miso.Widgets.Dialog as Dialog
 import qualified Functora.Miso.Widgets.Icon as Icon
 import qualified Functora.Miso.Widgets.Qr as Qr
 import qualified Functora.Miso.Widgets.Select as Select
+import Language.Javascript.JSaddle ((!))
 import qualified Language.Javascript.JSaddle as JS
 import qualified Miso.String as MS
 
@@ -166,7 +167,13 @@ field full@Full {fullArgs = args, fullParser = parser, fullViewer = viewer} opts
                       $ catMaybes
                         [ Just $ type_ "file",
                           Just $ accept_ "image/*",
-                          Just $ onInput onInputAction,
+                          Just $ onInput onInputFileAction,
+                          Just
+                            . id_
+                            . either impureThrow id
+                            . decodeUtf8Strict
+                            . unTagged
+                            $ htmlUid uid,
                           fmap required_
                             $ st
                             ^? cloneTraversal optic
@@ -299,6 +306,45 @@ field full@Full {fullArgs = args, fullParser = parser, fullViewer = viewer} opts
               & cloneTraversal optic
               . #fieldOutput
               %~ maybe id (const . id) (getOutput next)
+    onInputFileAction =
+      const . fromMaybe action (optsOnInputAction opts) . ImpureUpdate $ do
+        el <-
+          getElementById
+            . either impureThrow id
+            . decodeUtf8Strict
+            . unTagged
+            $ htmlUid uid
+        elExist <- ghcjsPure $ JS.isTruthy el
+        if not elExist
+          then pure id
+          else do
+            file <-
+              el JS.! ("files" :: Unicode) JS.!! 0
+            link <-
+              JS.global
+                ! ("URL" :: Unicode)
+                ^. JS.js1 ("createObjectURL" :: Unicode) file
+            murl <-
+              JS.fromJSVal link
+            case murl of
+              Nothing -> pure id
+              Just (url :: Unicode) -> do
+                let next =
+                      st
+                        & cloneTraversal optic
+                        . #fieldInput
+                        . #uniqueValue
+                        .~ url
+                pure
+                  $ ( cloneTraversal optic
+                        . #fieldInput
+                        . #uniqueValue
+                        .~ url
+                    )
+                  . ( cloneTraversal optic
+                        . #fieldOutput
+                        %~ maybe id (const . id) (getOutput next)
+                    )
 
 ratioField ::
   Args model action Rational Unique ->