refactor pages

2024-06-04 14:36:26 +02:00
parent 03b019ca96
commit ed753b0410
7 changed files with 361 additions and 202 deletions
--- a/frontend/app/Schema.hs
+++ b/frontend/app/Schema.hs
@@ -0,0 +1,101 @@
+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
+
+module Schema
+  ( Schema,
+    viewSchema,
+    schemaForm,
+  )
+where
+
+import Data.Aeson qualified as A
+import Data.Aeson.Key qualified as AK
+import Data.Aeson.KeyMap qualified as AM
+import Data.List
+import Data.Map qualified as M
+import Data.Maybe
+import Data.Text qualified as T
+import Form qualified as F
+import Miso
+import Miso.String (toMisoString)
+
+data Schema = Schema
+  { id :: String,
+    schema :: String,
+    title :: String,
+    type_ :: SchemaType
+  }
+  deriving (Show, Eq)
+
+instance A.FromJSON Schema where
+  parseJSON =
+    A.withObject
+      "Schema"
+      ( \v ->
+          Schema
+            <$> v A..: "$id"
+            <*> v A..: "$schema"
+            <*> v A..: "title"
+            <*> A.parseJSON (A.Object v)
+      )
+
+data SchemaType = Object (M.Map String String)
+  deriving (Show, Eq)
+
+instance A.FromJSON SchemaType where
+  parseJSON =
+    A.withObject
+      "SchemaType"
+      ( \v ->
+          v A..: "type" >>= \case
+            ("object" :: String) -> Object <$> v A..: "properties"
+      )
+
+viewSchema :: Schema -> View action
+viewSchema schema =
+  case schema.type_ of
+    Object properties ->
+      ol_ [] $
+        ( \(k, v) ->
+            li_ [] $
+              [ text (toMisoString k),
+                text ":",
+                text (toMisoString v)
+              ]
+        )
+          <$> (M.toList properties)
+
+schemaForm :: Schema -> F.Form A.Value A.Value
+schemaForm schema =
+  fmap mergeJson . sequence $
+    case schema.type_ of
+      Object properties ->
+        ( \(AK.fromString -> k, "string") ->
+            A.Object . AM.singleton k
+              <$> ( F.mapValues (getO k) (setO k) $
+                      jsonString (AK.toString k)
+                  )
+        )
+          <$> (M.toList properties)
+
+mergeJson :: [A.Value] -> A.Value
+mergeJson = foldl' mergeObject (A.Object AM.empty)
+
+mergeObject :: A.Value -> A.Value -> A.Value
+mergeObject (A.Object kvs) (A.Object kvs') = A.Object (AM.union kvs kvs')
+
+fromJson :: A.Value -> T.Text
+fromJson (A.String x) = x
+fromJson _ = ""
+
+toJson :: T.Text -> A.Value -> A.Value
+toJson x _ = A.String x
+
+getO :: AK.Key -> A.Value -> A.Value
+getO k (A.Object kvs) = fromMaybe A.Null (AM.lookup k kvs)
+
+setO :: AK.Key -> A.Value -> A.Value -> A.Value
+setO k v (A.Object kvs) = A.Object (AM.insert k v kvs)
+
+jsonString :: String -> F.Form A.Value A.Value
+jsonString = fmap A.String . F.mapValues fromJson toJson . F.string