fetchUrlAsRfc2397

Author: functora

ghcjs/delivery-calculator/delivery-calculator.cabal

@@ -16,6 +16,7 @@ common pkg
   hs-source-dirs:     src
   js-sources:         static/app.js
   other-modules:
+    App.Jsm
     App.Types
     App.Widgets.Asset
     App.Widgets.Fav

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

@@ -0,0 +1,44 @@
+module App.Jsm (fetchBlobUris) where
+
+import App.Types
+import qualified Data.Generics as Syb
+import qualified Data.Map as Map
+import qualified Functora.Miso.Jsm as Jsm
+import Functora.Miso.Prelude
+import qualified Text.URI as URI
+
+fetchBlobUris :: (Data a) => a -> JSM a
+fetchBlobUris st = do
+  vars <-
+    forM blobUris $ \uri -> do
+      var <- newEmptyMVar
+      Jsm.fetchUrlAsRfc2397 uri $ liftIO . putMVar var . fmap (uri,)
+      pure var
+  vals <-
+    fmap (fromList . catMaybes)
+      . forM vars
+      $ liftIO
+      . takeMVar
+  pure
+    $ Syb.everywhere
+      ( Syb.mkT $ \(x :: Field DynamicField Unique) ->
+          case Map.lookup (x ^. #fieldInput . #uniqueValue) vals of
+            Just val
+              | fieldType x == FieldTypeImage ->
+                  x
+                    & #fieldInput
+                    . #uniqueValue
+                    .~ val
+                    & #fieldOutput
+                    .~ DynamicFieldText val
+            _ -> x
+      )
+      st
+  where
+    blobUris =
+      nubOrd
+        . filter (\x -> URI.mkScheme "blob" == (URI.mkURI x >>= URI.uriScheme))
+        . fmap (^. #fieldInput . #uniqueValue)
+        $ Syb.listify
+          (\(x :: Field DynamicField Unique) -> fieldType x == FieldTypeImage)
+          st

ghcjs/delivery-calculator/src/App/Widgets/Menu.hs

@@ -5,6 +5,7 @@ module App.Widgets.Menu
   )
 where
 
+import qualified App.Jsm as Jsm
 import App.Types
 import qualified App.Widgets.Fav as Fav
 import qualified App.Xlsx as Xlsx
@@ -90,16 +91,13 @@ menu st =
               style_
                 [ ("min-width", "0")
                 ],
-              onClick
-                . PushUpdate
-                . Instant
-                . ImpureUpdate
-                $ do
-                  Jsm.saveFile
-                    "delivery-calculator.xlsx"
-                    "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet"
-                    Xlsx.newXlsx
-                  pure id
+              onClick . PushUpdate . Instant . EffectUpdate $ do
+                res <- Jsm.fetchBlobUris $ st ^. #modelState . #stAssets
+                consoleLog res
+                Jsm.saveFile
+                  "delivery-calculator.xlsx"
+                  "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet"
+                  Xlsx.newXlsx
             ]
             [ icon Icon.IconDownload
             ],

ghcjs/miso-functora/js/main.js

@@ -32,7 +32,7 @@ export async function selectClipboard() {
   const { value } = await Clipboard.read();
   try {
     const { buffer: u8a, typeFull: mime } = dataUriToBuffer(value);
-    const blob = new Blob([u8a, { type: mime }]);
+    const blob = new Blob([u8a], { type: mime });
     return URL.createObjectURL(blob);
   } catch (e) {
     return value;
@@ -84,7 +84,7 @@ export async function saveFile(name, mime, bs) {
     });
     return uri;
   } else {
-    const blob = new Blob([u8a, { type: mime }]);
+    const blob = new Blob([u8a], { type: mime });
     await saveAs(blob, name);
     return null;
   }

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

@@ -40,15 +40,14 @@ popupText x = do
 
 shareText :: (Show a, Data a) => a -> Update model
 shareText x =
-  ImpureUpdate $ do
+  EffectUpdate $ do
     let txt = inspect @Unicode x
     unless (txt == mempty) $ do
       pkg <- getPkg
       prom <- pkg ^. JS.js1 ("shareText" :: Unicode) txt
       success <- JS.function $ \_ _ _ -> popupText @Unicode "Copied!"
       failure <- JS.function $ \_ _ _ -> popupText @Unicode "Failed to copy!"
       void $ prom ^. JS.js2 ("then" :: Unicode) success failure
-    pure id
 
 moveUp :: ATraversal' model [item] -> Int -> Update model
 moveUp optic idx =
@@ -104,14 +103,13 @@ swapAt i j xs
 
 openBrowserPage :: URI -> Update model
 openBrowserPage uri =
-  ImpureUpdate $ do
+  EffectUpdate $ do
     pkg <- getPkg
     void $ pkg ^. JS.js1 @Unicode "openBrowserPage" (URI.render uri)
-    pure id
 
 enterOrEscapeBlur :: Uid -> KeyCode -> Update model
 enterOrEscapeBlur uid (KeyCode code) =
-  ImpureUpdate $ do
+  EffectUpdate $ do
     let enterOrEscape = [13, 27] :: [Int]
     when (code `elem` enterOrEscape) $ do
       --
@@ -123,10 +121,9 @@ enterOrEscapeBlur uid (KeyCode code) =
           . unTagged
           $ "document.getElementById('"
           <> htmlUid uid
-          <> "').getElementsByTagName('input')[0].blur();"
+          <> "').blur();"
       void
         $ JS.eval res
-    pure id
 
 insertStorage :: (ToJSON a) => Unicode -> a -> JSM ()
 insertStorage key raw = do

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

@@ -218,7 +218,6 @@ import Data.Sequences as X hiding
     group,
     groupBy,
     intersperse,
-    isPrefixOf,
     permutations,
     replicate,
     replicateM,
@@ -295,6 +294,7 @@ import Universum as X hiding
     handleAny,
     inits,
     intercalate,
+    isPrefixOf,
     lines,
     on,
     over,