Implement client routing

7 files changed, 139 insertions, 48 deletions

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
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
diff --git a/client/src/View/NotFound.hs b/client/src/View/NotFound.hs
new file mode 100644
index 0000000..1d4e477
--- /dev/null
+++ b/client/src/View/NotFound.hs
@@ -0,0 +1,20 @@
+module View.NotFound
+  ( view
+  ) where
+
+import qualified Data.Map   as M
+import           Reflex.Dom (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+import qualified Common.Msg as Msg
+import qualified Component  as Component
+
+view :: forall t m. MonadWidget t m => m ()
+view =
+  R.divClass "notfound" $ do
+    R.text (Msg.get Msg.NotFound_Message)
+
+    Component.link
+      "/"
+      (R.constDyn $ M.singleton "class" "link")
+      (Msg.get Msg.NotFound_LinkMessage)
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index f2a5071..1072a5e 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -1,7 +1,6 @@
 module View.Payment
   ( widget
   , PaymentIn(..)
-  , PaymentOut(..)
   ) where
 
 import           Data.Text           (Text)
@@ -26,11 +25,7 @@ data PaymentIn = PaymentIn
   { _paymentIn_init :: Init
   }
 
-data PaymentOut = PaymentOut
-  {
-  }
-
-widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut
+widget :: forall t m. MonadWidget t m => PaymentIn -> m ()
 widget paymentIn = do
   R.elClass "main" "payment" $ do
     rec
@@ -86,7 +81,7 @@ widget paymentIn = do
             ]
         }
 
-    pure $ PaymentOut {}
+    pure ()
 
 debounceSearchName
   :: forall t m. MonadWidget t m
diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs
index e7e319e..521c1a7 100644
--- a/client/src/View/Payment/Delete.hs
+++ b/client/src/View/Payment/Delete.hs
@@ -44,7 +44,7 @@ view input _ =
 
           let url =
                 R.ffor (_input_payment input) (\id ->
-                  T.concat ["/payment/", T.pack . show $ _payment_id id]
+                  T.concat ["/api/payment/", T.pack . show $ _payment_id id]
                 )
 
           (result, waiting) <- WaitFor.waitFor
diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs
index 187b64b..7819836 100644
--- a/client/src/View/Payment/Form.hs
+++ b/client/src/View/Payment/Form.hs
@@ -143,7 +143,7 @@ view input = do
                 })
 
             (addPayment, waiting) <- WaitFor.waitFor
-              (ajax "/payment")
+              (ajax "/api/payment")
               (ValidationUtil.fireValidation payment confirm)
 
           return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm)
diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs
index f8b985f..8c248bd 100644
--- a/client/src/View/SignIn.hs
+++ b/client/src/View/SignIn.hs
@@ -50,7 +50,7 @@ view signInMessage =
         let form = SignInForm <$> _inputOut_raw input
 
         (signInResult, waiting) <- WaitFor.waitFor
-          (Ajax.postJson "/askSignIn")
+          (Ajax.postJson "/api/askSignIn")
           (ValidationUtil.fireMaybe
             ((\f -> f <$ SignInValidation.signIn f) <$> form)
             validate)