fix frontend

1 files changed, 71 insertions, 71 deletions

diff --git a/frontend/app/Schema.hs b/frontend/app/Schema.hs
index a9a093b..8e49d47 100644
--- a/frontend/app/Schema.hs
+++ b/frontend/app/Schema.hs
@@ -9,62 +9,65 @@ module Schema
   )
 where
 
+import Control.Applicative ((<|>))
 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.Set qualified as S
 import Form qualified as F
 import Miso
 import Miso.String (MisoString, fromMisoString, toMisoString)
 import Route
 
 data Schema = Schema
-  { id :: String,
-    schema :: String,
-    title :: String,
-    type_ :: SchemaType
+  { id :: MisoString,
+    schema :: MisoString,
+    properties :: M.Map MisoString Property,
+    required :: S.Set MisoString,
+    title :: MisoString,
+    type_ :: MisoString
   }
   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)
-      )
+  parseJSON = A.withObject "Schema" $ \v ->
+    Schema
+      <$> v A..: "$id"
+      <*> v A..: "$schema"
+      <*> v A..: "properties"
+      <*> v A..: "required"
+      <*> v A..: "title"
+      <*> v A..: "type"
 
-data SchemaType = Object (M.Map String String)
+data Property
+  = Type MisoString
+  | Reference MisoString
   deriving (Show, Eq)
 
-instance A.FromJSON SchemaType where
-  parseJSON =
-    A.withObject
-      "SchemaType"
-      ( \v ->
-          v A..: "type" >>= \case
-            ("object" :: String) -> Object <$> v A..: "properties"
-      )
+instance A.FromJSON Property where
+  parseJSON = A.withObject "Property" $ \v ->
+    (Type <$> v A..: "type")
+      <|> (Reference <$> v A..: "$ref")
 
 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)
+  ol_ [] $
+    ( \(k, v) ->
+        li_ [] $
+          [ text (toMisoString k),
+            text ":",
+            text
+              ( case v of
+                  Type v -> toMisoString v
+                  Reference v -> "reference to " <> toMisoString v
+              ),
+            text (if k `S.member` schema.required then "" else "?")
+          ]
+    )
+      <$> (M.toList schema.properties)
 
 schemaTable :: MisoString -> Schema -> [A.Object] -> View action
 schemaTable collection schema values =
@@ -72,60 +75,57 @@ schemaTable collection schema values =
   where
     thead =
       thead_ [] $
-        case schema.type_ of
-          Object properties ->
-            [ tr_ [] $
-                [ th_ [] [text (toMisoString k)]
-                  | k <- M.keys properties
+        [ tr_ [] $
+            [ th_ [] [text (toMisoString k)]
+              | k <- M.keys schema.properties
+            ]
+        ]
+    tbody =
+      tbody_ [] $
+        [ tr_
+            []
+            [ td_ [] $
+                [ case (k, getO (AK.fromText (fromMisoString k)) value) of
+                    ("$fileName", A.String fn) ->
+                      a_
+                        [ href_
+                            (routeToMisoString (EditValue collection (toMisoString fn)))
+                        ]
+                        [ text (toMisoString fn)
+                        ]
+                    (_, v) ->
+                      text $
+                        case v of
+                          A.String s -> toMisoString s
+                          _ -> toMisoString (A.encode v)
                 ]
+              | k <- M.keys schema.properties
             ]
-    tbody = tbody_ [] $
-      case schema.type_ of
-        Object properties ->
-          [ tr_
-              []
-              [ td_ [] $
-                  [ case (k, getO (AK.fromString k) value) of
-                      ("$fileName", A.String fn) ->
-                        a_
-                          [ href_
-                              (routeToMisoString (EditValue collection (toMisoString fn)))
-                          ]
-                          [ text (toMisoString fn)
-                          ]
-                      (_, v) ->
-                        text $
-                          case v of
-                            A.String s -> toMisoString s
-                            _ -> toMisoString (A.encode v)
-                  ]
-                | k <- M.keys properties
-              ]
-            | value <- values
-          ]
+          | value <- values
+        ]
 
 schemaForm :: Schema -> F.Form A.Object A.Object
 schemaForm schema =
   fmap mergeJson . sequence $
-    case schema.type_ of
-      Object properties ->
-        ( \(AK.fromString -> k, v) ->
-            case v of
-              "string" ->
+    ( \((AK.fromText . fromMisoString) -> k, v) ->
+        case v of
+          Type "string" ->
+            if toMisoString (AK.toText k) `S.member` schema.required
+              then
                 AM.singleton k
                   <$> ( F.mapValues (getO k) (setO k) $
                           fmap (A.String . fromMisoString) . F.mapValues fromJson toJson $
                             F.input (toMisoString (AK.toString k))
                       )
-              "string?" ->
+              else
                 AM.singleton k
                   <$> ( F.mapValues (getO k) (setO k)
                           $ fmap (maybe A.Null (A.String . fromMisoString))
                             . F.mapValues fromJson toJson
                           $ F.optional (F.input (toMisoString (AK.toString k)))
                       )
-        )
-          <$> (M.toList properties)
+    )
+      <$> (M.toList schema.properties)
 
 mergeJson :: [A.Object] -> A.Object
 mergeJson = foldl' mergeObject AM.empty