aboutsummaryrefslogtreecommitdiff
path: root/client/src/View/Header.hs
diff options
context:
space:
mode:
Diffstat (limited to 'client/src/View/Header.hs')
-rw-r--r--client/src/View/Header.hs123
1 files changed, 0 insertions, 123 deletions
diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs
deleted file mode 100644
index ff9f40a..0000000
--- a/client/src/View/Header.hs
+++ /dev/null
@@ -1,123 +0,0 @@
-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