add querying

backend/app/Main.hs

@@ -23,6 +23,7 @@ import Network.HTTP.Types.Status qualified as W
 import Network.Wai qualified as W
 import Network.Wai.Handler.Warp qualified as W
 import Options.Applicative qualified as A
+import Store qualified as Q
 import System.Directory (setCurrentDirectory)
 import System.FilePath
 import Text.Printf (printf)
@@ -117,16 +118,25 @@ main = do
           Right (SchemaJson path) -> do
             let [c] = filter ((== path) . (.path)) (head repo.commits).collections
             respond $ W.responseLBS W.status200 [] (J.encode c.schema)
+          Right Query -> do
+            q <-
+              fromString @Q.Query . LB.toString
+                <$> W.lazyRequestBody req
+            r <- liftIO $ Q.withStore root ref (Q.query q)
+            respond . W.responseLBS W.status200 [] $ J.encode r
           (Debug.Trace.traceShowId -> !_) ->
-            respond $ W.responseLBS W.status200 [] "OK"
+            respond $ W.responseLBS W.status200 [] "not implemented"
 
 data Route
   = SchemaJson String
+  | Query
   deriving (Show)
 
 routeP :: P.Parser Route
 routeP =
-  ( SchemaJson
-      <$> (P.string "/" *> P.manyTill P.anyChar (P.string ".schema.json"))
+  ( P.choice
+      [ SchemaJson <$> (P.string "/" *> P.manyTill P.anyChar (P.string ".schema.json")),
+        pure Query <* (P.string "/")
+      ]
   )
     <* P.endOfInput

frontend/app/Main.hs

@@ -1,28 +1,71 @@
 module Main where
 
 #ifndef ghcjs_HOST_OS
-import Language.Javascript.JSaddle.Warp as JSaddle
-#endif
-
-import Data.ByteString.UTF8 qualified as B
-import Data.Maybe
-import Miso
-import Miso.String
-
-#ifndef ghcjs_HOST_OS
-import Network.HTTP.Simple
 import Data.String
+import Language.Javascript.JSaddle.Warp as JSaddle
+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
 
-type Model = Maybe Schema
+import Data.Aeson qualified as A
+import Data.ByteString.Lazy.Char8 qualified as LB
+import Data.Default
+import Data.Function
+import Data.Map qualified as M
+import GHC.Generics (Generic)
+import Miso
+import Miso.String (toMisoString)
 
-type Schema = String
+data Model = Model
+  { schema :: Maybe (Either String Schema),
+    posts :: Maybe (Either String [A.Value])
+  }
+  deriving (Show, Eq, Generic, Default)
+
+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"
+      )
 
 data Action
-  = FetchSchema
-  | SetSchema Schema
+  = NoOp
+  | Init
+  | FetchSchema
+  | SetSchema (Either String Schema)
+  | FetchPosts
+  | SetPosts (Either String [A.Value])
   deriving (Show, Eq)
 
 #ifndef ghcjs_HOST_OS
@@ -36,8 +79,8 @@ runApp app = app
 main :: IO ()
 main = runApp $ startApp App {..}
   where
-    initialAction = FetchSchema
-    model = Nothing
+    initialAction = Init
+    model = def
     update = updateModel
     view = viewModel
     events = defaultEvents
@@ -48,30 +91,85 @@ main = runApp $ startApp App {..}
 updateModel :: Action -> Model -> Effect Action Model
 updateModel action m =
   case action of
+    NoOp -> noEff m
+    Init -> batchEff m [pure FetchSchema, pure FetchPosts]
     FetchSchema -> m <# do SetSchema <$> fetchSchema
-    SetSchema schema -> noEff (Just schema)
+    SetSchema schema ->
+      let setSchema :: Either String Schema -> Model -> Model
+          setSchema schema m = m {schema = Just schema}
+       in noEff (setSchema schema m)
+    FetchPosts -> m <# do SetPosts <$> fetchPosts
+    SetPosts posts ->
+      let setPosts :: Either String [A.Value] -> Model -> Model
+          setPosts posts m = m {posts = Just posts}
+       in noEff (setPosts posts m)
 
-fetchSchema :: JSM String
-fetchSchema = fetch "http://localhost:8081/posts.schema.json"
+fetchSchema :: JSM (Either String Schema)
+fetchSchema =
+  A.eitherDecode <$> fetch (fromString "http://localhost:8081/posts.schema.json")
 
-#ifndef ghcjs_HOST_OS
-fetch :: String -> JSM String
-fetch url = B.toString . getResponseBody <$> httpBS (fromString url)
-#else
-fetch :: String -> JSM String
-fetch url = maybe "" B.toString . contents <$> xhrByteString req
-  where
-    req =
-      Request
-        { reqMethod = GET,
-          reqURI = pack url,
-          reqLogin = Nothing,
-          reqHeaders = [],
-          reqWithCredentials = False,
-          reqData = NoData
-        }
+fetchPosts :: JSM (Either String [A.Value])
+fetchPosts =
+  A.eitherDecode
+    <$> fetch
+      ( fromString "http://localhost:8081"
+          & setRequestMethod "POST"
+          & setRequestBodyLBS "SELECT posts FROM posts"
+      )
+
+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
 
 viewModel :: Model -> View Action
-viewModel schema =
-  div_ [] [text (toMisoString (fromMaybe ".." schema))]
+viewModel model =
+  div_ [] $
+    [ maybe (text "..") (either err viewSchema) model.schema,
+      maybe (text "..") (either err viewPosts) model.posts
+    ]
+
+err :: String -> View Action
+err = text . toMisoString . ("err! " <>)
+
+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)
+
+viewPosts :: [A.Value] -> View Action
+viewPosts posts = ol_ [] (viewPost <$> posts)
+  where
+    viewPost post = pre_ [] [text (toMisoString (A.encode post))]

frontend/frontend.cabal

@@ -12,12 +12,21 @@ executable frontend
     main-is:            Main.hs
     hs-source-dirs:     app
     default-language:   GHC2021
-    default-extensions: CPP OverloadedStrings RecordWildCards
-    ghc-options:        -Wall
+    default-extensions:
+        CPP OverloadedStrings RecordWildCards DeriveAnyClass
+        DuplicateRecordFields LambdaCase OverloadedRecordDot
+        NoFieldSelectors
+
+    ghc-options:
+        -Wall -fno-warn-name-shadowing -fno-warn-ambiguous-fields
+        -fno-warn-incomplete-patterns -fno-warn-orphans
+
     build-depends:
+        aeson,
         base,
         bytestring,
         containers,
+        data-default,
         miso,
         text,
         utf8-string
@@ -27,5 +36,6 @@ executable frontend
 
     if arch(javascript)
         build-depends: ghcjs-base
+
     else
         build-depends: http-conduit