diff options
Diffstat (limited to 'frontend/app/Main.hs')
| -rw-r--r-- | frontend/app/Main.hs | 244 |
1 files changed, 45 insertions, 199 deletions
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"]] + ] + ] |