aboutsummaryrefslogtreecommitdiffstats
path: root/frontend/app
diff options
context:
space:
mode:
Diffstat (limited to 'frontend/app')
-rw-r--r--frontend/app/Api.hs64
-rw-r--r--frontend/app/Main.hs244
-rw-r--r--frontend/app/Page.hs43
-rw-r--r--frontend/app/Page/ListCollection.hs70
-rw-r--r--frontend/app/Route.hs30
-rw-r--r--frontend/app/Schema.hs101
6 files changed, 353 insertions, 199 deletions
diff --git a/frontend/app/Api.hs b/frontend/app/Api.hs
new file mode 100644
index 0000000..2a26c66
--- /dev/null
+++ b/frontend/app/Api.hs
@@ -0,0 +1,64 @@
+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
+
+module Api
+ ( fetchSchema,
+ fetchPosts,
+ )
+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.Function
+import Miso
+import Schema
+
+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"
+ )
+
+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/Main.hs b/frontend/app/Main.hs
index 9151705..7345a98 100644
--- a/frontend/app/Main.hs
+++ b/frontend/app/Main.hs
@@ -1,81 +1,31 @@
module Main where
#ifndef ghcjs_HOST_OS
-import Data.Maybe
-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
-import Data.Aeson qualified as A
-import Data.Aeson.Key qualified as AK
-import Data.Aeson.KeyMap qualified as AM
-import Data.ByteString.Lazy.Char8 qualified as LB
+import Data.Bifunctor
import Data.Default
import Data.Function
-import Data.List
-import Data.Map qualified as M
-import Data.Text qualified as T
-import Form qualified as F
import GHC.Generics (Generic)
import Miso
import Miso.String (toMisoString)
import NeatInterpolation qualified as Q
+import Page (Page, initialPage, updatePage, viewPage)
+import Page qualified as Page
+import Route (parseURI)
data Model = Model
- { schema :: Maybe (Either String Schema),
- posts :: Maybe (Either String [A.Value]),
- input :: Maybe A.Value
+ { page :: Maybe (Either String Page)
}
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
= NoOp
- | Init
- | FetchSchema
- | SetSchema (Either String Schema)
- | FetchPosts
- | SetPosts (Either String [A.Value])
- | FormChanged A.Value
- | FormSubmitted A.Value
+ | Init URI
+ | HandleURI URI
+ | HandlePage Page.Action
+ | SetPage (Either String Page)
deriving (Show, Eq)
#ifndef ghcjs_HOST_OS
@@ -87,92 +37,49 @@ runApp app = app
#endif
main :: IO ()
-main = runApp $ startApp App {..}
+main = runApp $ do
+ uri <- getCurrentURI
+ startApp App {initialAction = Init uri, ..}
where
- initialAction = Init
model = def
update = updateModel
view = viewModel
events = defaultEvents
- subs = []
+ subs = [uriSub HandleURI]
mountPoint = Nothing
logLevel = Off
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 ->
- 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)
- FormChanged (Just -> input) -> noEff m {input}
- FormSubmitted output ->
- m <# do
- const NoOp <$> consoleLog (toMisoString (A.encode output))
-
-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"
- )
-
-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
+updateModel NoOp m = noEff m
+updateModel (Init uri) m =
+ m <# do
+ SetPage <$> initialPage (parseURI uri)
+updateModel (HandleURI uri) m =
+ m <# do
+ let route = parseURI uri
+ SetPage <$> initialPage route
+updateModel (SetPage page) m = noEff m {page = Just page}
+updateModel (HandlePage action) m =
+ case m.page of
+ Just (Right page) ->
+ updatePage action page
+ & bimap HandlePage (\page -> m {page = Just (Right page)})
+ _ -> noEff m
viewModel :: Model -> View Action
viewModel model =
- let input = fromMaybe (A.Object AM.empty) model.input
- in div_ [] $
- [ viewCss,
- viewHeader,
- nav_ [] [viewCollections],
- main_ [] $
- [ maybe (text "..") (either err viewSchema) model.schema,
- maybe (text "..") (either err viewPosts) model.posts,
- maybe (text "..") (either err (viewForm input)) model.schema,
- viewInput input
- ]
+ div_ [] $
+ [ viewCss,
+ viewHeader,
+ nav_ [] [viewCollections],
+ main_ [] $
+ [ HandlePage
+ <$> maybe
+ (text "..")
+ (either err viewPage)
+ model.page
]
+ ]
viewCss :: View Action
viewCss =
@@ -244,13 +151,13 @@ header section:first-child {
)
]
-err :: String -> View Action
+err :: String -> View action
err = text . toMisoString . ("err! " <>)
viewHeader :: View Action
viewHeader =
header_ [] $
- [ section_ [] [h1_ [] [text "acms"]],
+ [ section_ [] [h1_ [] [a_ [href_ "#"] [text "acms"]]],
section_ [] [viewBranch]
]
@@ -262,69 +169,8 @@ viewCollections :: View Action
viewCollections =
section_ [] $
[ span_ [] [text "collections"],
- ol_ [] [li_ [] [a_ [href_ "#"] [text "posts"]]]
- ]
-
-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)
-
-viewForm :: A.Value -> Schema -> View Action
-viewForm input =
- fmap (either FormChanged FormSubmitted)
- . flip F.runForm input
- . schemaForm
-
-viewInput :: A.Value -> View Action
-viewInput input =
- pre_ [] [text (toMisoString (A.encode input))]
-
-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
-
-viewPosts :: [A.Value] -> View Action
-viewPosts posts = ol_ [] (viewPost <$> posts)
- where
- viewPost post = pre_ [] [text (toMisoString (A.encode post))]
+ [ li_ [] [a_ [href_ "#collection/posts"] [text "posts"]],
+ li_ [] [a_ [href_ "#collection/posts1"] [text "posts1"]]
+ ]
+ ]
diff --git a/frontend/app/Page.hs b/frontend/app/Page.hs
new file mode 100644
index 0000000..84a551f
--- /dev/null
+++ b/frontend/app/Page.hs
@@ -0,0 +1,43 @@
+module Page
+ ( Page (..),
+ Action,
+ initialPage,
+ updatePage,
+ viewPage,
+ )
+where
+
+import Data.Bifunctor
+import Data.Default
+import Data.Function
+import Miso
+import Page.ListCollection qualified as ListCollection
+import Route (Route)
+import Route qualified as Route
+
+data Page
+ = Home
+ | ListCollection ListCollection.Model
+ deriving (Show, Eq)
+
+instance Default Page where
+ def = Home
+
+data Action
+ = HandleListCollection ListCollection.Action
+ deriving (Show, Eq)
+
+initialPage :: Route -> JSM (Either String Page)
+initialPage Route.Home = pure (Right Home)
+initialPage (Route.ListCollection c) =
+ fmap ListCollection <$> ListCollection.initialModel c
+
+updatePage :: Action -> Page -> Effect Action Page
+updatePage (HandleListCollection action) (ListCollection m) =
+ ListCollection.updateModel action m
+ & bimap HandleListCollection ListCollection
+updatePage (HandleListCollection _) p = noEff p
+
+viewPage :: Page -> View Action
+viewPage Home = text "home"
+viewPage (ListCollection m) = HandleListCollection <$> ListCollection.viewModel m
diff --git a/frontend/app/Page/ListCollection.hs b/frontend/app/Page/ListCollection.hs
new file mode 100644
index 0000000..102973e
--- /dev/null
+++ b/frontend/app/Page/ListCollection.hs
@@ -0,0 +1,70 @@
+module Page.ListCollection
+ ( Model,
+ initialModel,
+ Action,
+ updateModel,
+ viewModel,
+ )
+where
+
+import Api
+import Data.Aeson qualified as A
+import Data.Aeson.KeyMap qualified as AM
+import Form qualified as F
+import Miso
+import Miso.String (toMisoString)
+import Schema
+
+data Model = Model
+ { collection :: String,
+ input :: A.Value,
+ schema :: Schema,
+ posts :: [A.Value]
+ }
+ deriving (Show, Eq)
+
+initialModel :: String -> JSM (Either String Model)
+initialModel collection = do
+ schema' <- fetchSchema
+ posts' <- fetchPosts
+ pure do
+ schema <- schema'
+ posts <- posts'
+ pure $ Model {input = A.Object AM.empty, ..}
+
+data Action
+ = NoOp
+ | FormChanged A.Value
+ | FormSubmitted A.Value
+ deriving (Eq, Show)
+
+updateModel :: Action -> Model -> Effect Action Model
+updateModel NoOp m = noEff m
+updateModel (FormChanged input) m = noEff m {input}
+updateModel (FormSubmitted output) m =
+ m <# do
+ const NoOp <$> consoleLog (toMisoString (A.encode output))
+
+viewModel :: Model -> View Action
+viewModel m =
+ div_ [] $
+ [ viewSchema m.schema,
+ viewPosts m.posts,
+ viewForm m.input m.schema,
+ viewInput m.input
+ ]
+
+viewForm :: A.Value -> Schema -> View Action
+viewForm input =
+ fmap (either FormChanged FormSubmitted)
+ . flip F.runForm input
+ . schemaForm
+
+viewInput :: A.Value -> View Action
+viewInput input =
+ pre_ [] [text (toMisoString (A.encode input))]
+
+viewPosts :: [A.Value] -> View Action
+viewPosts posts = ol_ [] (viewPost <$> posts)
+ where
+ viewPost post = pre_ [] [text (toMisoString (A.encode post))]
diff --git a/frontend/app/Route.hs b/frontend/app/Route.hs
new file mode 100644
index 0000000..36e1462
--- /dev/null
+++ b/frontend/app/Route.hs
@@ -0,0 +1,30 @@
+module Route
+ ( Route (..),
+ parseURI,
+ )
+where
+
+import Data.Attoparsec.Text qualified as P
+import Data.Default
+import Data.Text qualified as T
+import Miso
+
+data Route
+ = Home
+ | ListCollection String
+ deriving (Show, Eq)
+
+instance Default Route where
+ def = Home
+
+parseURI :: URI -> Route
+parseURI uri =
+ either (const def) id $
+ P.parseOnly
+ ( P.choice
+ [ ListCollection <$> (P.string "#collection/" *> P.many1 P.anyChar),
+ pure Home
+ ]
+ <* P.endOfInput
+ )
+ (T.pack uri.uriFragment)
diff --git a/frontend/app/Schema.hs b/frontend/app/Schema.hs
new file mode 100644
index 0000000..e2d2e15
--- /dev/null
+++ 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
generated by cgit v1.2.3 (git 2.25.1) at 2025-01-23 16:53:04 +0000