wip

functora · functora · commit 5f34cd922ecd · 2024-10-31T16:01:51.000-03:00
diff --git a/ghcjs/delivery-calculator/src/App/Types.hs b/ghcjs/delivery-calculator/src/App/Types.hs
@@ -172,18 +172,18 @@ newAsset = do
       $ DynamicFieldText mempty
   opfs <-
     either throw pure . decodeUtf8Strict . unTagged . htmlUid =<< newUid
+  let opts =
+        BlobOpts
+          { blobOptsOpfsDir = Just $ "delivery-calculator-" <> vsn,
+            blobOptsOpfsFile = Just opfs,
+            blobOptsMaxSizeKb = Just 400000
+          }
   photo <-
     fmap
       ( ( #fieldPairValue
-            . #fieldSelectOpts
-            . #selectOptsOpfsName
-            .~ Just opfs
+            . #fieldBlobOpts
+            .~ opts
         )
-          . ( #fieldPairValue
-                . #fieldSelectOpts
-                . #selectOptsMaxSizeKb
-                .~ Just 400000
-            )
           . ( #fieldPairValue
                 . #fieldType
                 .~ FieldTypeImage
diff --git a/ghcjs/delivery-calculator/src/Main.hs b/ghcjs/delivery-calculator/src/Main.hs
@@ -455,9 +455,14 @@ opfsRead sink st =
               . #assetFieldPairs
               . ix fieldIdx
               . #fieldPairValue
-      when (field ^. #fieldType == FieldTypeImage)
-        $ whenJust (field ^. #fieldSelectOpts . #selectOptsOpfsName)
-        $ \opfsName -> Jsm.opfsRead opfsName . flip whenJust $ \uri ->
+      when
+        ( (field ^. #fieldType == FieldTypeImage)
+            && isJust (field ^. #fieldBlobOpts . #blobOptsOpfsDir)
+            && isJust (field ^. #fieldBlobOpts . #blobOptsOpfsFile)
+        )
+        $ Jsm.opfsRead (fieldBlobOpts field)
+        . flip whenJust
+        $ \uri ->
           liftIO
             . sink
             . PushUpdate
diff --git a/ghcjs/miso-functora/js/main.js b/ghcjs/miso-functora/js/main.js
@@ -78,56 +78,92 @@ export async function resolveDataUrl(value, opts = {}) {
       }
       blob = await compressImage(blob, maxSizeKb);
     }
-    if (opts.opfsName) {
-      await opfsWrite(value, opts.opfsName);
+    if (opts.opfsDir && opts.opfsFile) {
+      await opfsWrite(value, opts);
     }
     return URL.createObjectURL(blob);
   } catch (e) {
     return value;
   }
 }
 
-export async function opfsWrite(value, opfsName) {
+export async function opfsWrite(value, { opfsDir, opfsFile }) {
   try {
     const root = await navigator.storage.getDirectory();
-    const handle = await root.getFileHandle(opfsName, { create: true });
-    const stream = await handle.createWritable();
+    const dir = await root.getDirectoryHandle(opfsDir, { create: true });
+    const file = await dir.getFileHandle(opfsFile, { create: true });
+    const stream = await file.createWritable();
     await stream.write(value);
     await stream.close();
   } catch (e) {
-    alert("OPFS write failure: " + e.toString() + " file: " + opfsName);
+    alert(
+      "OPFS write failure: " +
+        e.toString() +
+        " dir: " +
+        opfsDir +
+        " file: " +
+        opfsFile,
+    );
   }
   return null;
 }
 
-export async function opfsRead(opfsName) {
+export async function opfsRead({ opfsDir, opfsFile }) {
   try {
     const root = await navigator.storage.getDirectory();
-    const handle = await root.getFileHandle(opfsName);
-    const file = await handle.getFile();
-    const uri = await file.text();
+    const dir = await root.getDirectoryHandle(opfsDir);
+    const file = await dir.getFileHandle(opfsFile);
+    const blob = await file.getFile();
+    const uri = await blob.text();
     const res = await resolveDataUrl(uri);
     return res;
   } catch (e) {
-    alert("OPFS read failure: " + e.toString() + " file: " + opfsName);
+    alert(
+      "OPFS read failure: " +
+        e.toString() +
+        " dir: " +
+        opfsDir +
+        " file: " +
+        opfsFile,
+    );
     return null;
   }
 }
 
-export async function opfsList() {
+export async function opfsList(opfsDir) {
   try {
     const res = [];
     const root = await navigator.storage.getDirectory();
-    for await (let opfsName of root.keys()) {
-      res.push(opfsName);
+    const dir = await root.getDirectoryHandle(opfsDir);
+    for await (let opfsFile of dir.keys()) {
+      res.push(opfsFile);
     }
     return res;
   } catch (e) {
-    alert("OPFS list failure: " + e.toString() + " file: " + opfsName);
+    alert("OPFS list failure: " + e.toString() + " dir: " + opfsDir);
     return [];
   }
 }
 
+export async function opfsRemove({ opfsDir, opfsFile }) {
+  try {
+    const root = await navigator.storage.getDirectory();
+    const dir = await root.getDirectoryHandle(opfsDir);
+    const file = await dir.getFileHandle(opfsFile);
+    await file.remove();
+  } catch (e) {
+    alert(
+      "OPFS remove failure: " +
+        e.toString() +
+        " dir: " +
+        opfsDir +
+        " file: " +
+        opfsFile,
+    );
+  }
+  return null;
+}
+
 export async function openBrowserPage(url) {
   try {
     return await Browser.open({ url: url, windowName: "_blank" });
diff --git a/ghcjs/miso-functora/js/main.min.js b/ghcjs/miso-functora/js/main.min.js
diff --git a/ghcjs/miso-functora/src/Functora/Miso/Jsm/Generic.hs b/ghcjs/miso-functora/src/Functora/Miso/Jsm/Generic.hs
@@ -7,14 +7,13 @@ module Functora.Miso.Jsm.Generic
     openBrowserPage,
     enterOrEscapeBlur,
     insertStorage,
-    SelectOpts (..),
-    defSelectOpts,
     selectStorage,
     selectBarcode,
     selectClipboard,
     selectFile,
     opfsRead,
     opfsList,
+    opfsRemove,
     genericPromise,
     printCurrentPage,
     saveFileShow,
@@ -154,29 +153,36 @@ selectBarcode after =
     $ after
     . fmap strip
 
-selectClipboard :: SelectOpts -> (Maybe Unicode -> JSM ()) -> JSM ()
+selectClipboard :: BlobOpts -> (Maybe Unicode -> JSM ()) -> JSM ()
 selectClipboard opts after = do
   jopts <- JS.toJSVal $ toJSON opts
   genericPromise @[JS.JSVal] @Unicode "selectClipboard" [jopts]
     $ after
     . fmap strip
 
-selectFile :: SelectOpts -> JS.JSVal -> (Maybe Unicode -> JSM ()) -> JSM ()
+selectFile :: BlobOpts -> 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
 
-opfsRead :: Unicode -> (Maybe Unicode -> JSM ()) -> JSM ()
-opfsRead opfsName after = do
-  genericPromise @[Unicode] @Unicode "opfsRead" [opfsName]
+opfsRead :: BlobOpts -> (Maybe Unicode -> JSM ()) -> JSM ()
+opfsRead opts after = do
+  jopts <- JS.toJSVal $ toJSON opts
+  genericPromise @[JS.JSVal] @Unicode "opfsRead" [jopts]
     $ after
     . fmap strip
 
-opfsList :: (Maybe [Unicode] -> JSM ()) -> JSM ()
-opfsList after =
-  genericPromise @[Unicode] @[Unicode] "opfsList" mempty after
+opfsList :: Unicode -> (Maybe [Unicode] -> JSM ()) -> JSM ()
+opfsList dir after =
+  genericPromise @[Unicode] @[Unicode] "opfsList" [dir] after
+
+opfsRemove :: BlobOpts -> JSM ()
+opfsRemove opts = do
+  pkg <- getPkg
+  jopts <- JS.toJSVal $ toJSON opts
+  void $ pkg ^. JS.js1 @Unicode "opfsRemove" jopts
 
 genericPromise ::
   forall args res.
diff --git a/ghcjs/miso-functora/src/Functora/Miso/Types.hs b/ghcjs/miso-functora/src/Functora/Miso/Types.hs
@@ -58,8 +58,8 @@ module Functora.Miso.Types
     themeCssFile,
     noopAll,
     noop,
-    SelectOpts (..),
-    defSelectOpts,
+    BlobOpts (..),
+    defBlobOpts,
     module X,
   )
 where
@@ -130,7 +130,7 @@ data Field a f = Field
   { fieldType :: FieldType,
     fieldInput :: f Unicode,
     fieldOutput :: a,
-    fieldSelectOpts :: SelectOpts,
+    fieldBlobOpts :: BlobOpts,
     fieldModalState :: OpenedOrClosed,
     fieldFocusState :: FocusedOrBlurred,
     fieldRequired :: Bool,
@@ -186,7 +186,7 @@ newField typ output newInput = do
       { fieldType = typ,
         fieldInput = input,
         fieldOutput = output,
-        fieldSelectOpts = defSelectOpts,
+        fieldBlobOpts = defBlobOpts,
         fieldModalState = Closed,
         fieldFocusState = Blurred,
         fieldRequired = False,
@@ -199,7 +199,7 @@ newFieldId typ viewer output =
     { fieldType = typ,
       fieldInput = Identity $ viewer output,
       fieldOutput = output,
-      fieldSelectOpts = defSelectOpts,
+      fieldBlobOpts = defBlobOpts,
       fieldModalState = Closed,
       fieldFocusState = Blurred,
       fieldRequired = False,
@@ -620,16 +620,18 @@ noop action event =
     . EffectUpdate
     $ pure ()
 
-data SelectOpts = SelectOpts
-  { selectOptsOpfsName :: Maybe Unicode,
-    selectOptsMaxSizeKb :: Maybe Int
+data BlobOpts = BlobOpts
+  { blobOptsOpfsDir :: Maybe Unicode,
+    blobOptsOpfsFile :: Maybe Unicode,
+    blobOptsMaxSizeKb :: Maybe Int
   }
   deriving stock (Eq, Ord, Show, Data, Generic)
-  deriving (Binary, ToJSON, FromJSON) via GenericType SelectOpts
-
-defSelectOpts :: SelectOpts
-defSelectOpts =
-  SelectOpts
-    { selectOptsOpfsName = Nothing,
-      selectOptsMaxSizeKb = Nothing
+  deriving (Binary, ToJSON, FromJSON) via GenericType BlobOpts
+
+defBlobOpts :: BlobOpts
+defBlobOpts =
+  BlobOpts
+    { blobOptsOpfsDir = Nothing,
+      blobOptsOpfsFile = Nothing,
+      blobOptsMaxSizeKb = Nothing
     }
diff --git a/ghcjs/miso-functora/src/Functora/Miso/Widgets/Field.hs b/ghcjs/miso-functora/src/Functora/Miso/Widgets/Field.hs
@@ -343,10 +343,10 @@ field full@Full {fullArgs = args, fullParser = parser, fullViewer = viewer} opts
           else do
             file <- el JS.! ("files" :: Unicode) JS.!! 0
             Jsm.selectFile
-              ( fromMaybe defSelectOpts
+              ( fromMaybe defBlobOpts
                   $ st
                   ^? cloneTraversal optic
-                  . #fieldSelectOpts
+                  . #fieldBlobOpts
               )
               file
               $ \case
@@ -461,8 +461,8 @@ fieldIcon full opts = \case
       . insertAction full
       . Jsm.selectClipboard
       $ fromMaybe
-        defSelectOpts
-        (st ^? cloneTraversal optic . #fieldSelectOpts)
+        defBlobOpts
+        (st ^? cloneTraversal optic . #fieldBlobOpts)
   ScanQrWidget ->
     fieldIconSimple opts Icon.IconQrCode mempty
       $ insertAction full Jsm.selectBarcode
