refactor pages

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

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.Bifunctor
-import Data.Aeson.Key qualified as AK
-import Data.Aeson.KeyMap qualified as AM
-import Data.ByteString.Lazy.Char8 qualified as LB
 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),
+  { page :: Maybe (Either String Page)
-    posts :: Maybe (Either String [A.Value]),
-    input :: Maybe 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
   = NoOp
-  | Init
+  | Init URI
-  | FetchSchema
+  | HandleURI URI
-  | SetSchema (Either String Schema)
+  | HandlePage Page.Action
-  | FetchPosts
+  | SetPage (Either String Page)
-  | SetPosts (Either String [A.Value])
-  | FormChanged A.Value
-  | FormSubmitted A.Value
   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 =
+updateModel NoOp m = noEff m
-  case action of
+updateModel (Init uri) m =
-    NoOp -> noEff m
+  m <# do
-    Init -> batchEff m [pure FetchSchema, pure FetchPosts]
+    SetPage <$> initialPage (parseURI uri)
-    FetchSchema -> m <# do SetSchema <$> fetchSchema
+updateModel (HandleURI uri) m =
-    SetSchema schema ->
+  m <# do
-      let setSchema :: Either String Schema -> Model -> Model
+    let route = parseURI uri
-          setSchema schema m = m {schema = Just schema}
+    SetPage <$> initialPage route
-       in noEff (setSchema schema m)
+updateModel (SetPage page) m = noEff m {page = Just page}
-    FetchPosts -> m <# do SetPosts <$> fetchPosts
+updateModel (HandlePage action) m =
-    SetPosts posts ->
+  case m.page of
-      let setPosts :: Either String [A.Value] -> Model -> Model
+    Just (Right page) ->
-          setPosts posts m = m {posts = Just posts}
+      updatePage action page
-       in noEff (setPosts posts m)
+        & bimap HandlePage (\page -> m {page = Just (Right page)})
-    FormChanged (Just -> input) -> noEff m {input}
+    _ -> noEff m
-    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
 
 viewModel :: Model -> View Action
 viewModel model =
-  let input = fromMaybe (A.Object AM.empty) model.input
+  div_ [] $
-   in div_ [] $
+    [ viewCss,
-        [ viewCss,
+      viewHeader,
-          viewHeader,
+      nav_ [] [viewCollections],
-          nav_ [] [viewCollections],
+      main_ [] $
-          main_ [] $
+        [ HandlePage
-            [ maybe (text "..") (either err viewSchema) model.schema,
+            <$> maybe
-              maybe (text "..") (either err viewPosts) model.posts,
+              (text "..")
-              maybe (text "..") (either err (viewForm input)) model.schema,
+              (either err viewPage)
-              viewInput input
+              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_ [] [a_ [href_ "#collection/posts"] [text "posts"]],
-            li_ [] $
+          li_ [] [a_ [href_ "#collection/posts1"] [text "posts1"]]
-              [ 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))]

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

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))]

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)

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

frontend/frontend.cabal

@@ -12,23 +12,28 @@ executable frontend
     main-is:            Main.hs
     hs-source-dirs:     app
     other-modules:
+        Api
         Form
         Form.Input
         Form.Internal
+        Page
+        Page.ListCollection
+        Route
+        Schema
 
     default-language:   GHC2021
     default-extensions:
         CPP OverloadedStrings RecordWildCards DeriveAnyClass
         DuplicateRecordFields LambdaCase OverloadedRecordDot
-        NoFieldSelectors ViewPatterns QuasiQuotes
+        NoFieldSelectors ViewPatterns QuasiQuotes BlockArguments
 
     ghc-options:
         -Wall -fno-warn-name-shadowing -fno-warn-ambiguous-fields
-        -fno-warn-incomplete-patterns -fno-warn-orphans
+        -fno-warn-orphans
-        -fno-warn-incomplete-uni-patterns
 
     build-depends:
         aeson,
+        attoparsec,
         base,
         bytestring,
         containers,