From 74e4a576cf7193ba56f45f26b8597e6533a7d8d1 Mon Sep 17 00:00:00 2001 From: Alexander Foremny Date: Mon, 3 Jun 2024 11:22:10 +0200 Subject: add querying --- backend/app/Main.hs | 16 ++++- frontend/app/Main.hs | 170 ++++++++++++++++++++++++++++++++++++++---------- frontend/frontend.cabal | 14 +++- 3 files changed, 159 insertions(+), 41 deletions(-) diff --git a/backend/app/Main.hs b/backend/app/Main.hs index e75ce99..82d2d38 100644 --- a/backend/app/Main.hs +++ b/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 diff --git a/frontend/app/Main.hs b/frontend/app/Main.hs index d1bb89e..fc26e69 100644 --- a/frontend/app/Main.hs +++ b/frontend/app/Main.hs @@ -1,28 +1,71 @@ module Main where #ifndef ghcjs_HOST_OS +import Data.String 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 #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) + +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) + ) -type Schema = String +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))] diff --git a/frontend/frontend.cabal b/frontend/frontend.cabal index 5674bb7..fc8ab23 100644 --- a/frontend/frontend.cabal +++ b/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 -- cgit v1.2.3