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/Header.hs | 65 +++++++++++++++++++++++++++++++++++------------
 1 file changed, 49 insertions(+), 16 deletions(-)

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

diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs
index 8f1fb78..9a4de89 100644
--- a/client/src/View/Header.hs
+++ b/client/src/View/Header.hs
@@ -4,40 +4,73 @@ module View.Header
   , HeaderOut(..)
   ) where
 
-import qualified Data.Map         as M
-import           Data.Time        (NominalDiffTime)
-import           Prelude          hiding (error, init)
-import           Reflex.Dom       (Event, MonadWidget)
-import qualified Reflex.Dom       as R
-
-import           Common.Model     (Init (..), InitResult (..), User (..))
-import qualified Common.Model     as CM
-import qualified Common.Msg       as Msg
-import qualified Component        as Component
-import           Component.Button (ButtonIn (..))
+import           Data.Map     (Map)
+import qualified Data.Map     as M
+import           Data.Text    (Text)
+import qualified Data.Text    as T
+import           Data.Time    (NominalDiffTime)
+import           Prelude      hiding (error, init)
+import           Reflex.Dom   (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom   as R
+
+import           Common.Model (Init (..), InitResult (..), User (..))
+import qualified Common.Model as CM
+import qualified Common.Msg   as Msg
+import           Component    (ButtonIn (..))
+import qualified Component    as Component
 import qualified Icon
+import           Model.Route  (Route (..))
+import qualified Util.Css     as CssUtil
+import qualified Util.Reflex  as ReflexUtil
 
-data HeaderIn = HeaderIn
-  { _headerIn_initResult :: InitResult
+data HeaderIn t = HeaderIn
+  { _headerIn_initResult    :: InitResult
+  , _headerIn_isInitSuccess :: Bool
+  , _headerIn_route         :: Dynamic t Route
   }
 
 data HeaderOut t = HeaderOut
   { _headerOut_signOut :: Event t ()
   }
 
-view :: forall t m. MonadWidget t m => HeaderIn -> m (HeaderOut t)
+view :: forall t m. MonadWidget t m => (HeaderIn t) -> m (HeaderOut t)
 view headerIn =
   R.el "header" $ do
 
     R.divClass "title" $
       R.text $ Msg.get Msg.App_Title
 
-    signOut <- nameSignOut $ _headerIn_initResult headerIn
+    signOut <- R.el "div" $ do
+      rec
+        showLinks <- R.foldDyn const (_headerIn_isInitSuccess headerIn) (False <$ signOut)
+        ReflexUtil.visibleIfDyn showLinks R.blank (links $ _headerIn_route headerIn)
+        signOut <- nameSignOut $ _headerIn_initResult headerIn
+      return signOut
 
     return $ HeaderOut
       { _headerOut_signOut = signOut
       }
 
+links :: forall t m. MonadWidget t m => Dynamic t Route -> m ()
+links route = do
+  Component.link
+    "/"
+    (R.ffor route (attrs RootRoute))
+    (Msg.get Msg.Payment_Title)
+
+  Component.link
+    "/income"
+    (R.ffor route (attrs IncomeRoute))
+    (Msg.get Msg.Income_Title)
+
+  where
+    attrs linkRoute currentRoute =
+      M.singleton "class" $
+        CssUtil.classes
+          [ ("item", True)
+          , ("current", linkRoute == currentRoute)
+          ]
+
 nameSignOut :: forall t m. MonadWidget t m => InitResult -> m (Event t ())
 nameSignOut initResult = case initResult of
   (InitSuccess init) -> do
@@ -76,5 +109,5 @@ signOutButton = do
   where askSignOut :: forall t m. MonadWidget t m => Event t () -> m (Event t Bool)
         askSignOut signOut =
           fmap getResult <$> R.performRequestAsync xhrRequest
-          where xhrRequest = fmap (const $ R.postJson "/signOut" ()) signOut
+          where xhrRequest = fmap (const $ R.postJson "/api/signOut" ()) signOut
                 getResult = (== 200) . R._xhrResponse_status
-- 
cgit v1.2.3