add edit page

default.nix

@@ -28,6 +28,7 @@ rec {
       haskellPackages.frontend
     ];
     buildInputs = [
+      haskellPackages.astore
       haskellPackages.cabal-install
       haskellPackages.ormolu
       (pkgs.writeScriptBin "reload" ''

frontend/app/Api.hs

@@ -3,6 +3,8 @@
 module Api
   ( fetchSchema,
     fetchPosts,
+    fetchPost,
+    updatePost,
   )
 where
 
@@ -18,8 +20,10 @@ import Miso.String qualified as J
 #endif
 import Data.Aeson qualified as A
 import Data.ByteString.Lazy.Char8 qualified as LB
+import Data.ByteString.Lazy.UTF8 qualified as LB
 import Data.Function
 import Miso
+import Safe
 import Schema
 
 fetchSchema :: JSM (Either String Schema)
@@ -35,6 +39,24 @@ fetchPosts =
           & setRequestBodyLBS "SELECT posts FROM posts"
       )
 
+fetchPost :: String -> JSM (Either String (Maybe A.Value))
+fetchPost fileName =
+  fmap headMay . A.eitherDecode
+    <$> fetch
+      ( fromString "http://localhost:8081"
+          & setRequestMethod "POST"
+          & setRequestBodyLBS ("SELECT posts FROM posts WHERE posts.$fileName == \"" <> LB.fromString fileName <> "\"")
+      )
+
+updatePost :: String -> A.Value -> JSM (Either String ())
+updatePost fileName value =
+  A.eitherDecode
+    <$> fetch
+      ( fromString "http://localhost:8081"
+          & setRequestMethod "POST"
+          & setRequestBodyLBS ("UPDATE posts SET " <> A.encode value <> " WHERE posts.$fileName == \"" <> LB.fromString fileName <> "\"")
+      )
+
 fetch :: Request -> JSM LB.ByteString
 fetch req = LB.fromStrict . getResponseBody <$> httpBS req
 

frontend/app/Page.hs

@@ -11,6 +11,7 @@ import Data.Bifunctor
 import Data.Default
 import Data.Function
 import Miso
+import Page.EditValue qualified as EditValue
 import Page.ListCollection qualified as ListCollection
 import Route (Route)
 import Route qualified as Route
@@ -18,26 +19,35 @@ import Route qualified as Route
 data Page
   = Home
   | ListCollection ListCollection.Model
+  | EditValue EditValue.Model
+  deriving (Show, Eq)
+
+data Action
+  = HandleListCollection ListCollection.Action
+  | HandleEditValue EditValue.Action
   deriving (Show, Eq)
 
 instance Default Page where
   def = Home
 
-data Action
-  = HandleListCollection ListCollection.Action
-  deriving (Show, Eq)
-
 initialPage :: Route -> JSM (Either String Page)
 initialPage Route.Home = pure (Right Home)
 initialPage (Route.ListCollection c) =
   fmap ListCollection <$> ListCollection.initialModel c
+initialPage (Route.EditValue c f) =
+  fmap EditValue <$> EditValue.initialModel c f
 
 updatePage :: Action -> Page -> Effect Action Page
 updatePage (HandleListCollection action) (ListCollection m) =
   ListCollection.updateModel action m
     & bimap HandleListCollection ListCollection
 updatePage (HandleListCollection _) p = noEff p
+updatePage (HandleEditValue action) (EditValue m) =
+  EditValue.updateModel action m
+    & bimap HandleEditValue EditValue
+updatePage (HandleEditValue _) p = noEff p
 
 viewPage :: Page -> View Action
 viewPage Home = text "home"
 viewPage (ListCollection m) = HandleListCollection <$> ListCollection.viewModel m
+viewPage (EditValue m) = HandleEditValue <$> EditValue.viewModel m

frontend/app/Page/EditValue.hs

@@ -0,0 +1,66 @@
+module Page.EditValue
+  ( Model,
+    initialModel,
+    Action,
+    updateModel,
+    viewModel,
+  )
+where
+
+import Api
+import Data.Aeson qualified as A
+import Data.Aeson.KeyMap qualified as AM
+import Data.Maybe
+import Form qualified as F
+import Miso
+import Miso.String (toMisoString)
+import Schema
+
+data Model = Model
+  { collection :: String,
+    fileName :: String,
+    input :: Maybe A.Value,
+    schema :: Schema
+  }
+  deriving (Show, Eq)
+
+initialModel :: String -> String -> JSM (Either String Model)
+initialModel collection fileName = do
+  schema' <- fetchSchema
+  input' <- fetchPost fileName
+  pure do
+    schema <- schema'
+    input <- input'
+    pure $ Model {..}
+
+data Action
+  = NoOp
+  | FormChanged A.Value
+  | FormSubmitted A.Value
+  | EntityWritten (Either String ())
+  deriving (Eq, Show)
+
+updateModel :: Action -> Model -> Effect Action Model
+updateModel NoOp m = noEff m
+updateModel (FormChanged (Just -> input)) m = noEff m {input}
+updateModel (FormSubmitted output) m =
+  m <# do EntityWritten <$> updatePost m.fileName output
+updateModel (EntityWritten _) m = noEff m
+
+viewModel :: Model -> View Action
+viewModel m = do
+  let input = (fromMaybe (A.Object AM.empty) m.input)
+  div_ [] $
+    [ viewForm input m.schema,
+      viewInput input
+    ]
+
+viewForm :: A.Value -> Schema -> View Action
+viewForm input =
+  fmap (either FormChanged FormSubmitted)
+    . flip F.runForm input
+    . schemaForm
+
+viewInput :: A.Value -> View Action
+viewInput input =
+  pre_ [] [text (toMisoString (A.encode input))]

frontend/app/Route.hs

@@ -12,6 +12,7 @@ import Miso
 data Route
   = Home
   | ListCollection String
+  | EditValue String String
   deriving (Show, Eq)
 
 instance Default Route where
@@ -22,7 +23,10 @@ parseURI uri =
   either (const def) id $
     P.parseOnly
       ( P.choice
-          [ ListCollection <$> (P.string "#collection/" *> P.many1 P.anyChar),
+          [ EditValue
+              <$> (P.string "#collection/" *> P.manyTill P.anyChar (P.string "/"))
+              <*> (P.many1 P.anyChar),
+            ListCollection <$> (P.string "#collection/" *> P.many1 P.anyChar),
             pure Home
           ]
           <* P.endOfInput

frontend/frontend.cabal

@@ -17,6 +17,7 @@ executable frontend
         Form.Input
         Form.Internal
         Page
+        Page.EditValue
         Page.ListCollection
         Route
         Schema
@@ -40,6 +41,7 @@ executable frontend
         data-default,
         miso,
         neat-interpolation,
+        safe,
         text,
         utf8-string
 

nix/sources.json

@@ -2,7 +2,7 @@
     "json2sql": {
         "branch": "main",
         "repo": "git@code.nomath.org:~/json2sql",
-        "rev": "bbe3b75bfd0767c61bcd436e843b9c785efd289f",
+        "rev": "04b43e75fb0822de7db67f108c3545dee451069c",
         "type": "git"
     },
     "nixpkgs": {