fix frontend

7 files changed, 81 insertions, 180 deletions

diff --git a/backend/lib/ACMS/API/REST/Collection.hs b/backend/lib/ACMS/API/REST/Collection.hs
index 09f7e32..3ca8ffd 100644
--- a/backend/lib/ACMS/API/REST/Collection.hs
+++ b/backend/lib/ACMS/API/REST/Collection.hs
@@ -15,9 +15,9 @@ import Collection
 import ACMS.API.REST (APIMonad, fetch, restRequest)
 import Data.Aeson qualified as A
 import Data.Function ((&))
+import Debug.Trace
 import Miso.String (MisoString)
 import Text.Printf (printf)
-import Debug.Trace
 
 list :: (APIMonad m) => Collection -> m [A.Object]
 list c =
diff --git a/frontend/app/Api.hs b/frontend/app/Api.hs
deleted file mode 100644
index 2b7598a..0000000
--- a/frontend/app/Api.hs
+++ /dev/null
@@ -1,107 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
-
-module Api
-  ( fetchCollections,
-    createCollection,
-    fetchSchema,
-    fetchSchemaVersion,
-    fetchPosts,
-    fetchPost,
-    updatePost,
-  )
-where
-
-#ifndef ghcjs_HOST_OS
-import Data.String
-import Network.HTTP.Simple
-#else
-import Data.ByteString.Char8 qualified as B
-import Data.Maybe
-import Data.String
-import JavaScript.Web.XMLHttpRequest
-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
-import Version
-
-fetchCollections :: JSM (Either String [String])
-fetchCollections =
-  A.eitherDecode <$> fetch (fromString "http://localhost:8081/collections")
-
-createCollection :: String -> JSM (Either String ())
-createCollection collection =
-  A.eitherDecode
-    <$> fetch
-      ( fromString "http://localhost:8081/collections"
-          & setRequestMethod "POST"
-          & setRequestBodyLBS (A.encode (A.toJSON collection))
-      )
-
-fetchSchemaVersion :: JSM (Either String Version)
-fetchSchemaVersion =
-  A.eitherDecode <$> fetch (fromString "http://localhost:8081/schemaVersion")
-
-fetchSchema :: JSM (Either String Schema)
-fetchSchema =
-  A.eitherDecode <$> fetch (fromString "http://localhost:8081/posts.schema.json")
-
-fetchPosts :: JSM (Either String [A.Value])
-fetchPosts =
-  A.eitherDecode
-    <$> fetch
-      ( fromString "http://localhost:8081"
-          & setRequestMethod "POST"
-          & 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
-
-#ifdef ghcjs_HOST_OS
-httpBS :: Request -> JSM (Response B.ByteString)
-httpBS req = xhrByteString req
-
-instance IsString Request where
-  fromString uri =
-    Request
-      { reqMethod = GET,
-        reqURI = J.pack uri,
-        reqLogin = Nothing,
-        reqHeaders = [],
-        reqWithCredentials = False,
-        reqData = NoData
-      }
-
-setRequestMethod :: B.ByteString -> Request -> Request
-setRequestMethod "POST" req = req {reqMethod = POST}
-
-setRequestBodyLBS :: LB.ByteString -> Request -> Request
-setRequestBodyLBS body req = req {reqData = StringData (J.pack (LB.unpack body))}
-
-getResponseBody :: Response B.ByteString -> B.ByteString
-getResponseBody = fromMaybe "" . contents
-#endif
diff --git a/frontend/app/Effect.hs b/frontend/app/Effect.hs
index ad87d72..a79754f 100644
--- a/frontend/app/Effect.hs
+++ b/frontend/app/Effect.hs
@@ -1,5 +1,8 @@
 module Effect (Eff (..)) where
 
+import Miso.String (MisoString)
+
 data Eff
   = ReloadCollections
+  | Log MisoString
   deriving (Show, Eq)
diff --git a/frontend/app/Main.hs b/frontend/app/Main.hs
index 9f30708..e4729b4 100644
--- a/frontend/app/Main.hs
+++ b/frontend/app/Main.hs
@@ -134,6 +134,11 @@ update__setCollections (Right collections) = Action $ \case
 
 handleEff :: Eff -> JSM Action
 handleEff E.ReloadCollections = update__setCollections <$> try API.REST.listCollections
+handleEff (E.Log s) = pure . Action $ \case
+  m -> m <# (noOp <$> consoleLog s)
+
+noOp :: () -> Action
+noOp _ = Action noEff
 
 viewModel :: Model -> View Action
 viewModel Loading = text ".."
diff --git a/frontend/app/Page/EditValue.hs b/frontend/app/Page/EditValue.hs
index 4ff867f..7945874 100644
--- a/frontend/app/Page/EditValue.hs
+++ b/frontend/app/Page/EditValue.hs
@@ -11,6 +11,7 @@ import ACMS.API.REST.Collection qualified as API.REST.Collection
 import Control.Monad.Catch (SomeException, try)
 import Data.Aeson qualified as A
 import Data.Aeson.KeyMap qualified as AM
+import Data.ByteString.Lazy.UTF8 qualified as LB
 import Data.Maybe
 import Effect (Eff)
 import Form qualified as F
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
diff --git a/frontend/frontend.cabal b/frontend/frontend.cabal
index 65b38f5..f01aced 100644
--- a/frontend/frontend.cabal
+++ b/frontend/frontend.cabal
@@ -12,7 +12,6 @@ executable frontend
     main-is:            Main.hs
     hs-source-dirs:     app
     other-modules:
-        Api
         Effect
         Form
         Form.Input