acms/frontend/app/Main.hs

module Main where

#ifndef ghcjs_HOST_OS
import Language.Javascript.JSaddle.Warp as JSaddle
#endif

import Api
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 (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 String
  | Loaded LoadedState
  deriving (Show, Eq)

data LoadedState = LoadedState
  { collections :: [String],
    schemaVersion :: Version,
    page :: Maybe (Either String Page)
  }
  deriving (Show, Eq)

instance Default Model where
  def = Loading

data Action
  = -- Loading
    SetLoaded (Either String LoadedState)
  | -- Loaded
    NoOp
  | Init URI
  | HandleURI URI
  | HandlePage Page.Action
  | SetPage (Either String Page)
  | HandleEff Eff
  | SetCollections (Either String [String])
  deriving (Show, Eq)

#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 = Init uri, ..}
  where
    model = def
    update = updateModel
    view = viewModel
    events = defaultEvents
    subs = [uriSub HandleURI]
    mountPoint = Nothing
    logLevel = Off

updateModel :: Action -> Model -> Effect Action Model
updateModel _ (Failed err) = noEff (Failed err)
updateModel (Init uri) Loading =
  Loading <# do
    page <- Just <$> initialPage (parseURI uri)
    schemaVersion' <- fetchSchemaVersion
    collections' <- fetchCollections
    pure $ SetLoaded do
      schemaVersion <- schemaVersion'
      collections <- collections'
      pure LoadedState {..}
updateModel (Init _) m = noEff m
updateModel (SetLoaded (Left err)) Loading = noEff (Failed err)
updateModel (SetLoaded (Right state)) Loading = noEff (Loaded state)
updateModel (SetLoaded _) m = noEff m
updateModel _ Loading = noEff Loading
updateModel NoOp (Loaded s) = noEff (Loaded s)
updateModel (HandleURI uri) (Loaded s) =
  Loaded s <# do
    let route = parseURI uri
    SetPage <$> initialPage route
updateModel (SetPage page) (Loaded s) = noEff (Loaded s {page = Just page})
updateModel (HandlePage action) (Loaded s) =
  case s.page of
    Just (Right page) ->
      fmap Loaded $
        ( case updatePage action page
            & first (bimap HandlePage (\page -> s {page = Just (Right page)}))
            & second (map HandleEff)
            & second (map (\eff -> (\sink -> liftIO (sink eff)))) of
            (Effect s' ss, ss') ->
              Effect s' (ss ++ ss')
        )
    _ -> noEff (Loaded s)
updateModel (HandleEff eff) (Loaded s) = Loaded s <# handleEff eff
updateModel (SetCollections (Left err)) (Loaded s) =
  Loaded s <# do
    pure NoOp <* consoleLog (toMisoString err)
updateModel (SetCollections (Right collections)) (Loaded s) =
  noEff (Loaded s {collections})

handleEff :: Eff -> JSM Action
handleEff E.ReloadCollections = SetCollections <$> fetchCollections

viewModel :: Model -> View Action
viewModel Loading = text ".."
viewModel (Failed s) = err s
viewModel (Loaded s) =
  div_ [] $
    [ viewCss,
      viewHeader s,
      nav_ [] [viewCollections s],
      main_ [] $
        [ 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 :: String -> View action
err = text . toMisoString . ("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
        ]
    ]