{-# LANGUAGE ViewPatterns #-} module Main where #ifndef ghcjs_HOST_OS import Language.Javascript.JSaddle.Warp as JSaddle #endif import ACMS.API.REST as API.REST import Control.Monad (join) import Control.Monad.Catch import Control.Monad.Trans import Data.Bifunctor import Data.Default import Data.Function import Effect (Eff) import Effect qualified as E import Miso import Miso.String (MisoString, toMisoString) import NeatInterpolation qualified as Q import Page (Page, initialPage, updatePage, viewPage) import Page qualified as Page import Route (parseURI) import Route qualified import Version data Model = Loading | Failed MisoString | Loaded LoadedState deriving (Show, Eq) data LoadedState = LoadedState { collections :: [MisoString], schemaVersion :: Version, page :: Maybe (Either MisoString Page) } deriving (Show, Eq) instance Default Model where def = Loading newtype Action = Action (Model -> Effect Action Model) #ifndef ghcjs_HOST_OS runApp :: JSM () -> IO () runApp f = JSaddle.debugOr 8080 (f >> syncPoint) JSaddle.jsaddleApp #else runApp :: IO () -> IO () runApp app = app #endif main :: IO () main = runApp $ do uri <- getCurrentURI startApp App {initialAction = update__init uri, ..} where model = def update (Action f) m = f m view = viewModel events = defaultEvents subs = [uriSub update__handleURI] mountPoint = Nothing logLevel = Off update__init :: URI -> Action update__init uri = Action $ \case Loading -> Loading <# do page <- Just . first (toMisoString . displayException) <$> initialPage (parseURI uri) schemaVersion' <- try API.REST.schemaVersion collections' <- try API.REST.listCollections pure $ update__setLoaded do schemaVersion <- schemaVersion' collections <- collections' pure LoadedState {..} m -> noEff m update__setLoaded :: Either SomeException LoadedState -> Action update__setLoaded (Left e) = Action $ \case Loading -> noEff (Failed (toMisoString (displayException e))) m -> noEff m update__setLoaded (Right s) = Action $ \case Loading -> noEff (Loaded s) m -> noEff m update__noOp :: Action update__noOp = Action noEff update__handleURI :: URI -> Action update__handleURI uri = Action $ \case Loaded s -> Loaded s <# do let route = parseURI uri update__setPage <$> initialPage route m -> noEff m update__setPage :: Either SomeException Page -> Action update__setPage ((Just . first (toMisoString . displayException)) -> page) = Action $ \case Loaded s -> noEff (Loaded s {page = page}) m -> noEff m update__handlePage :: Page.Action -> Action update__handlePage action = Action $ \case Loaded s -> case s.page of Just (Right page) -> fmap Loaded $ ( case updatePage action page & first (bimap update__handlePage (\page -> s {page = Just (Right page)})) & second (map update__handleEff) & second (map (\eff -> (\sink -> liftIO (sink eff)))) of (Effect s' ss, ss') -> Effect s' (ss ++ ss') ) _ -> noEff (Loaded s) m -> noEff m update__handleEff :: Eff -> Action update__handleEff eff = Action $ \case Loaded s -> Loaded s <# handleEff eff m -> noEff m update__setCollections :: Either SomeException [MisoString] -> Action update__setCollections (Left err) = Action $ \case Loaded s -> Loaded s <# do pure update__noOp <* consoleLog (toMisoString (displayException err)) m -> noEff m update__setCollections (Right collections) = Action $ \case Loaded s -> noEff (Loaded s {collections}) m -> noEff m handleEff :: Eff -> JSM Action handleEff E.ReloadCollections = update__setCollections <$> try API.REST.listCollections handleEff (E.Log s) = pure . Action $ \case m -> m <# (noOp <$> consoleLog s) noOp :: () -> Action noOp _ = Action noEff viewModel :: Model -> View Action viewModel Loading = text ".." viewModel (Failed s) = err s viewModel (Loaded s) = div_ [] $ [ viewCss, viewHeader s, nav_ [] [viewCollections s], main_ [] $ [ update__handlePage <$> maybe (text "..") (either err viewPage) s.page ] ] viewCss :: View Action viewCss = node HTML "style" Nothing [type_ "text/css"] [ text ( toMisoString [Q.text| /* normalize */ * { box-sizing: border-box; } body { margin: 0; min-height: 100vh; } /* typography */ html { font: Iosevka; } /* layout */ body > div { display: flex; flex-flow: row nowrap; min-height: 100vh; padding-top: 64px; align-items: stretch; } header { position: fixed; top: 0; left: 0; width: 100%; height: 64px; } nav, main { min-height: 100%; } nav { flex: 0 0 260px; } main { flex: 1 1 auto; } /* borders */ header { border-bottom: 1px solid gray; } nav { border-right: 1px solid gray; } /* padding */ nav, header, main { padding: 16px; } /* scrolling */ body > div { overflow: visible; } header { overflow: visible; } nav, main { overflow: auto; } /* header */ header { display: flex; align-items: center; } header section { margin-left: auto; } header section:first-child { margin-left: 0; } /* table layout */ th, td { text-align: left; padding: 0 16px; line-height: 52px; text-overflow: ellipsis; } /* table borders */ table { border-collapse: collapse; border-left: 1px solid gray; border-right: 1px solid gray; } th, td { border-top: 1px solid gray; border-bottom: 1px solid gray; } /* menu */ nav { padding: 16px 0 0; } nav ol { list-style-type: none; line-height: 32px; padding: 0; margin: 0; } nav { display: flex; flex-flow: column nowrap; height: calc(100vh - 64px); } nav section { display: flex; flex-flow: column nowrap; } nav section > span { line-height: 32px; padding-left: 8px; } nav section > span:not(:first-child) { margin-top: 24px; } nav li { white-space: pre; overflow: hidden; text-overflow: ellipsis; } nav li { display: flex; } nav li a { flex: 0 0 100%; padding: 4px 8px 4px; color: black; text-decoration: none; } nav li a.active { background-color: lightgray; } nav li a:hover, nav li a:active { background-color: whitesmoke; } /* main scrolling */ main { max-height: calc(100vh - 64px);} /* table */ table td { white-space: pre; overflow: hidden; text-overflow: ellipsis; max-width: 480px; } /* form */ .input label { display: block; padding-left: 6px; } .input .error-helper { display: block; padding-left: 6px; } .input label > div { margin-left: -6px; margin-right: -6px; } .input input { font-size: 1rem; margin-top: 4px; margin-bottom: 4px; } .input input[type=text] { padding: 2px 6px; } form { margin: -12px 0; } .error-helper { color: red; line-height: 1rem; height: 1rem; } .input { margin: 12px 0; } |] ) ] err :: MisoString -> View action err = text . ("err! " <>) viewHeader :: LoadedState -> View Action viewHeader s = header_ [] $ [ section_ [] [h1_ [] [a_ [href_ "#"] [text "acms"]]], section_ [] (viewBranch s) ] viewBranch :: LoadedState -> [View Action] viewBranch s = [ text (toMisoString (versionToString s.schemaVersion)), text " ", select_ [] [option_ [] [text "main"]] ] viewCollections :: LoadedState -> View Action viewCollections s = section_ [] $ [ span_ [] [ text "collections", text " ", a_ [href_ "#collection/new"] [text "+new"] ], ol_ [] $ [ li_ [] [ a_ ( concat [ [href_ (toMisoString ("#collection/" <> collection))], if ( fmap Page.route . join . fmap (either (\_ -> Nothing) Just) $ s.page ) == Just (Route.ListCollection collection) then [class_ "active"] else [] ] ) [text (toMisoString collection)] ] | collection <- s.collections ] ]