path: root/frontend/app/Main.hs

{-# 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.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 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 200px; }
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; }
|]
        )
    ]

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_
                [href_ (toMisoString ("#collection/" <> collection))]
                [text (toMisoString collection)]
            ]
          | collection <- s.collections
        ]
    ]