file upload support

Author: functora

ghcjs/delivery-calculator/delivery-calculator.cabal

@@ -1,6 +1,6 @@
 cabal-version: 2.2
 name:          delivery-calculator
-version:       0.1.0.3
+version:       0.1.0.4
 synopsis:      Delivery Calculator
 category:      Web
 build-type:    Simple

ghcjs/delivery-calculator/trapeze.yaml

@@ -1,8 +1,8 @@
 platforms:
   android:
     appName: Delivery Calculator
-    versionCode: 3
-    versionName: 0.1.0.3
+    versionCode: 4
+    versionName: 0.1.0.4
     packageName: com.functora.delivery_calculator
     manifest:
       - file: AndroidManifest.xml

ghcjs/miso-functora/js/main.js

@@ -44,6 +44,22 @@ export async function compressImage(quality, prevImage) {
 
 export async function selectClipboard() {
   const { value } = await Clipboard.read();
+  return await selectDataUrl(value);
+}
+
+export async function selectFile(file) {
+  const value = await new Promise((resolve, reject) => {
+    var fr = new FileReader();
+    fr.onload = () => {
+      resolve(fr.result);
+    };
+    fr.onerror = reject;
+    fr.readAsDataURL(file);
+  });
+  return await selectDataUrl(value);
+}
+
+export async function selectDataUrl(value) {
   try {
     const { buffer: u8a, typeFull: mime } = dataUriToBuffer(value);
     let blob = new Blob([u8a], { type: mime });

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

@@ -10,6 +10,7 @@ module Functora.Miso.Jsm.Generic
     selectStorage,
     selectBarcode,
     selectClipboard,
+    selectFile,
     genericPromise,
     printCurrentPage,
     saveFile,
@@ -166,6 +167,12 @@ selectClipboard after =
     $ after
     . fmap strip
 
+selectFile :: JS.JSVal -> (Maybe Unicode -> JSM ()) -> JSM ()
+selectFile file after =
+  genericPromise @[JS.JSVal] @Unicode "selectFile" [file]
+    $ after
+    . fmap strip
+
 genericPromise ::
   forall args res.
   ( JS.MakeArgs args,

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

@@ -25,7 +25,6 @@ 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
 
@@ -305,7 +304,7 @@ field full@Full {fullArgs = args, fullParser = parser, fullViewer = viewer} opts
               . #fieldOutput
               %~ maybe id (const . id) (getOutput next)
     onInputFileAction =
-      const . fromMaybe action (optsOnInputAction opts) . ImpureUpdate $ do
+      const . fromMaybe action (optsOnInputAction opts) . EffectUpdate $ do
         el <-
           getElementById
             . either impureThrow ("file-" <>)
@@ -314,35 +313,27 @@ field full@Full {fullArgs = args, fullParser = parser, fullViewer = viewer} opts
             $ htmlUid uid
         elExist <- ghcjsPure $ JS.isTruthy el
         if not elExist
-          then pure id
+          then Jsm.popupText @Unicode "File does not exist!"
           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
+            file <- el JS.! ("files" :: Unicode) JS.!! 0
+            Jsm.selectFile file $ \case
+              Nothing -> Jsm.popupText @Unicode "File is not selected!"
+              Just url -> argsEmitter args . PureUpdate $ do
                 let next =
                       st
                         & cloneTraversal optic
                         . #fieldInput
                         . #uniqueValue
                         .~ url
-                pure
-                  $ ( cloneTraversal optic
+                 in ( cloneTraversal optic
                         . #fieldInput
                         . #uniqueValue
                         .~ url
                     )
-                  . ( cloneTraversal optic
-                        . #fieldOutput
-                        %~ maybe id (const . id) (getOutput next)
-                    )
+                      . ( cloneTraversal optic
+                            . #fieldOutput
+                            %~ maybe id (const . id) (getOutput next)
+                        )
 
 ratioField ::
   Args model action Rational Unique ->