1 files changed, 123 insertions, 0 deletions
diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs
new file mode 100644
index 0000000..ff9f40a
--- /dev/null
+++ b/client/src/View/Header.hs
@@ -0,0 +1,123 @@
+module View.Header
+  ( view
+  , In(..)
+  , Out(..)
+  ) where
+
+import           Data.Map         (Map)
+import qualified Data.Map         as M
+import qualified Data.Maybe       as Maybe
+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 (..), User (..))
+import qualified Common.Model     as CM
+import qualified Common.Msg       as Msg
+import qualified Component.Button as Button
+import qualified Component.Link   as Link
+import           Model.Route      (Route (..))
+import qualified Util.Css         as CssUtil
+import qualified Util.Reflex      as ReflexUtil
+import qualified View.Icon        as Icon
+
+data In t = In
+  { _in_init  :: Dynamic t (Maybe Init)
+  , _in_route :: Dynamic t Route
+  }
+
+data Out t = Out
+  { _out_signOut :: Event t ()
+  }
+
+view :: forall t m. MonadWidget t m => (In t) -> m (Out t)
+view input =
+  R.el "header" $ do
+
+    R.divClass "title" $
+      R.text $ Msg.get Msg.App_Title
+
+    let showLinks = Maybe.isJust <$> _in_init input
+
+    signOut <- R.el "div" $ do
+      ReflexUtil.visibleIfDyn showLinks R.blank (links $ _in_route input)
+      (R.dyn $ nameSignOut <$> _in_init input) >>= ReflexUtil.flatten
+
+    return $ Out
+      { _out_signOut = signOut
+      }
+
+links :: forall t m. MonadWidget t m => Dynamic t Route -> m ()
+links route = do
+  Link.view
+    "/"
+    (R.ffor route (attrs RootRoute))
+    (Msg.get Msg.Payment_Title)
+
+  Link.view
+    "/income"
+    (R.ffor route (attrs IncomeRoute))
+    (Msg.get Msg.Income_Title)
+
+  Link.view
+    "/category"
+    (R.ffor route (attrs CategoryRoute))
+    (Msg.get Msg.Category_Title)
+
+  Link.view
+    "/statistics"
+    (R.ffor route (attrs StatisticsRoute))
+    (Msg.get Msg.Statistics_Title)
+
+  where
+    attrs linkRoute currentRoute =
+      M.singleton "class" $
+        CssUtil.classes
+          [ ("item", True)
+          , ("current", linkRoute == currentRoute)
+          ]
+
+nameSignOut :: forall t m. MonadWidget t m => Maybe Init -> m (Event t ())
+nameSignOut init =
+  case init of
+    Just init -> do
+      rec
+        attr <- R.holdDyn
+          (M.singleton "class" "nameSignOut")
+          (fmap (const $ M.fromList [("style", "visibility: hidden"), ("class", "nameSignOut")]) signOut)
+
+        signOut <- R.elDynAttr "nameSignOut" attr $ do
+          case CM.findUser (_init_currentUser init) (_init_users init) of
+            Just user -> R.divClass "name" $ R.text (_user_name user)
+            Nothing   -> R.blank
+          signOutButton
+
+      return signOut
+    _ ->
+      return R.never
+
+signOutButton :: forall t m. MonadWidget t m => m (Event t ())
+signOutButton = do
+  rec
+    signOut <- Button.view $
+      (Button.defaultIn Icon.signOut)
+        { Button._in_class = R.constDyn "signOut item"
+        , Button._in_waiting = waiting
+        }
+    let signOutClic = Button._out_clic signOut
+        waiting = R.leftmost
+          [ fmap (const True) signOutClic
+          , fmap (const False) signOutSuccess
+          ]
+    signOutSuccess <- askSignOut signOutClic >>= R.debounce (0.5 :: NominalDiffTime)
+
+  return . fmap (const ()) . R.ffilter (== True) $ signOutSuccess
+
+  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 "/api/signOut" ()) signOut
+                getResult = (== 200) . R._xhrResponse_status