1  {-# LANGUAGE RecursiveDo #-}
  2  {-# LANGUAGE TemplateHaskell #-}
  3  
  4  module Frontend (frontend) where
  5  
  6  import Common.Model (Config (..), darkMode)
  7  import Common.Route (FrontendRoute (..))
  8  import Control.Lens (preview, to, _Just)
  9  import Control.Monad (void)
 10  import Control.Monad.Fix (MonadFix)
 11  import Control.Monad.IO.Class (MonadIO)
 12  import Data.Maybe (isJust)
 13  import LocalStorage (load, save)
 14  import Obelisk.Frontend (Frontend (..))
 15  import Obelisk.Generated.Static (static)
 16  import Obelisk.Route (R, pattern (:/))
 17  import Obelisk.Route.Frontend (RouteToUrl, Routed, SetRoute (..), askRoute)
 18  import qualified Page.About as About
 19  import qualified Page.Browse as Browse
 20  import qualified Page.Search as Search
 21  import qualified Page.Settings as Settings
 22  import Reflex.Dom.Core
 23  import Theme (setDarkModeOn)
 24  import Witherable (catMaybes)
 25  
 26  data State
 27    = -- | The initial state: before the config is loaded from the local storage
 28      MkInit
 29    | -- | After the config is loaded from the local storage
 30      MkConfigLoaded (Maybe Config)
 31    deriving stock (Show, Eq)
 32  
 33  frontend :: Frontend (R FrontendRoute)
 34  frontend =
 35    Frontend
 36      { _frontend_head = frontendHead,
 37        _frontend_body = frontendBody
 38      }
 39  
 40  frontendHead :: DomBuilder t m => m ()
 41  frontendHead = do
 42    el "title" $ text "Diverk"
 43    elAttr
 44      "meta"
 45      ( "name" =: "viewport"
 46          <> "content" =: "width=device-width, initial-scale=1.0"
 47      )
 48      blank
 49  
 50    elAttr
 51      "link"
 52      ( "href" =: $(static "css/styles.css")
 53          <> "type" =: "text/css"
 54          <> "rel" =: "stylesheet"
 55      )
 56      blank
 57    elAttr
 58      "link"
 59      ( "href" =: $(static "fontawesome/css/all.css")
 60          <> "type" =: "text/css"
 61          <> "rel" =: "stylesheet"
 62      )
 63      blank
 64  
 65  frontendBody ::
 66    forall t m.
 67    ( DomBuilder t m,
 68      Prerender t m,
 69      Routed t (R FrontendRoute) m,
 70      MonadFix m,
 71      MonadHold t m,
 72      PostBuild t m,
 73      SetRoute t (R FrontendRoute) m,
 74      RouteToUrl (R FrontendRoute) m,
 75      PerformEvent t m,
 76      TriggerEvent t m,
 77      MonadIO (Performable m)
 78    ) =>
 79    m ()
 80  frontendBody = do
 81    evSettingsLoaded <- fmap MkConfigLoaded <$> load
 82    dyRoute <- askRoute
 83  
 84    rec dyState <- holdDyn MkInit $ leftmost [evSettingsLoaded, evSettingsSaved]
 85        let dyDarkModeOnRouteChange = getDarkMode <$> dyState <* dyRoute
 86            evDarkModeOnRouteChange = catMaybes $ updated dyDarkModeOnRouteChange
 87        void $ setDarkModeOn evDarkModeOnRouteChange
 88        evSettingsSaved <-
 89          switchHold never =<< dyn (route <$> dyRoute <*> dyState)
 90  
 91    pure ()
 92    where
 93      getConfig (MkConfigLoaded mbConfig) = mbConfig
 94      getConfig _ = Nothing
 95      getDarkMode = preview (to getConfig . _Just . darkMode)
 96  
 97  route ::
 98    ( DomBuilder t m,
 99      Prerender t m,
100      SetRoute t (R FrontendRoute) m,
101      PostBuild t m,
102      MonadHold t m,
103      MonadFix m,
104      RouteToUrl (R FrontendRoute) m,
105      PerformEvent t m,
106      TriggerEvent t m,
107      MonadIO (Performable m),
108      Routed t (R FrontendRoute) m
109    ) =>
110    R FrontendRoute ->
111    State ->
112    m (Event t State)
113  route (MkSettings :/ ()) (MkConfigLoaded mbConfig) = do
114    evOk <- Settings.page mbConfig
115    evSaved <- save evOk
116    setRoute $ MkBrowse :/ [] <$ evSaved
117    pure $ MkConfigLoaded . Just <$> evSaved
118  route (MkBrowse :/ path) (MkConfigLoaded (Just config)) = do
119    Browse.page config path
120    pure never
121  route
122    (MkSearch :/ keywords)
123    (MkConfigLoaded (Just (MkConfig owner repo (Just token) _))) = do
124      Search.page owner repo token keywords
125      pure never
126  route (MkHome :/ ()) (MkConfigLoaded (Just _)) = do
127    setRoute . (MkBrowse :/ [] <$) =<< getPostBuild
128    pure never
129  route _ (MkConfigLoaded Nothing) = do
130    setRoute . (MkSettings :/ () <$) =<< getPostBuild
131    pure never
132  route (MkAbout :/ ()) (MkConfigLoaded mbConfig) = do
133    About.page hasToken
134    pure never
135    where
136      hasToken = isJust $ coToken =<< mbConfig
137  route _ _ = pure never