From 52331eeadce8d250564851c25fc965172640bc55 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sat, 12 Oct 2019 11:23:10 +0200
Subject: Implement client routing

---
 client/src/View/App.hs | 87 +++++++++++++++++++++++++++++++++++++-------------
 1 file changed, 65 insertions(+), 22 deletions(-)

(limited to 'client/src/View/App.hs')

diff --git a/client/src/View/App.hs b/client/src/View/App.hs
index 6435297..d853c7e 100644
--- a/client/src/View/App.hs
+++ b/client/src/View/App.hs
@@ -2,41 +2,84 @@ module View.App
   ( widget
   ) where
 
-import           Prelude      hiding (error, init)
-import qualified Reflex.Dom   as R
+import qualified Data.Text     as T
+import           Prelude       hiding (error, init)
+import           Reflex.Dom    (Dynamic, MonadWidget)
+import qualified Reflex.Dom    as R
 
-import           Common.Model (InitResult (..))
-import qualified Common.Msg   as Msg
+import           Common.Model  (Init, InitResult (..))
+import qualified Common.Msg    as Msg
 
-import           View.Header  (HeaderIn (..))
-import qualified View.Header  as Header
-import           View.Payment (PaymentIn (..))
-import qualified View.Payment as Payment
-import qualified View.SignIn  as SignIn
+import           Model.Route   (Route (..))
+import qualified Util.Router   as Router
+import           View.Header   (HeaderIn (..))
+import qualified View.Header   as Header
+import qualified View.NotFound as NotFound
+import           View.Payment  (PaymentIn (..))
+import qualified View.Payment  as Payment
+import qualified View.SignIn   as SignIn
 
 widget :: InitResult -> IO ()
 widget initResult =
   R.mainWidget $ R.divClass "app" $ do
 
+    route <- getRoute
+
     headerOut <- Header.view $ HeaderIn
       { _headerIn_initResult = initResult
+      , _headerIn_isInitSuccess =
+        case initResult of
+          InitSuccess _ -> True
+          _             -> False
+      , _headerIn_route = route
       }
 
-    let signOut = Header._headerOut_signOut headerOut
+    let signOut =
+          Header._headerOut_signOut headerOut
+
+        mainContent =
+          case initResult of
+            InitSuccess init ->
+              signedWidget init route
+
+            InitEmpty ->
+              SignIn.view SignIn.EmptyMessage
 
-        initialContent = case initResult of
-          InitSuccess initSuccess -> do
-            _ <- Payment.widget $ PaymentIn
-              { _paymentIn_init = initSuccess
-              }
-            return ()
-          InitEmpty ->
-            SignIn.view SignIn.EmptyMessage
-          InitError error ->
-            SignIn.view (SignIn.ErrorMessage error)
+            InitError error ->
+              SignIn.view (SignIn.ErrorMessage error)
 
-        signOutContent = SignIn.view (SignIn.SuccessMessage $ Msg.get Msg.SignIn_DisconnectSuccess)
+        signOutContent =
+          SignIn.view (SignIn.SuccessMessage $ Msg.get Msg.SignIn_DisconnectSuccess)
 
-    _ <- R.widgetHold initialContent (fmap (const signOutContent) signOut)
+    _ <- R.widgetHold (mainContent) (signOutContent <$ signOut)
 
     R.blank
+
+signedWidget :: MonadWidget t m => Init -> Dynamic t Route -> m ()
+signedWidget init route = do
+  R.dyn . R.ffor route $ \case
+    RootRoute ->
+      Payment.widget $ PaymentIn
+        { _paymentIn_init = init
+        }
+
+    IncomeRoute ->
+      R.el "div" $ R.text "Incomes"
+
+    NotFoundRoute ->
+      NotFound.view
+
+  return ()
+
+getRoute :: MonadWidget t m => m (Dynamic t Route)
+getRoute = do
+  r <- Router.partialPathRoute "" . R.switchPromptlyDyn =<< R.holdDyn R.never R.never
+  return . R.ffor r $ \case
+    [""] ->
+      RootRoute
+
+    ["income"] ->
+      IncomeRoute
+
+    _ ->
+      NotFoundRoute
-- 
cgit v1.2.3