aboutsummaryrefslogtreecommitdiff
path: root/src/client/View/Header.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/client/View/Header.hs')
-rw-r--r--src/client/View/Header.hs86
1 files changed, 0 insertions, 86 deletions
diff --git a/src/client/View/Header.hs b/src/client/View/Header.hs
deleted file mode 100644
index 32738f1..0000000
--- a/src/client/View/Header.hs
+++ /dev/null
@@ -1,86 +0,0 @@
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecursiveDo #-}
-
-module View.Header
- ( view
- , HeaderIn(..)
- , HeaderOut(..)
- ) where
-
-import qualified Data.Map as M
-import Data.Time (NominalDiffTime)
-import Reflex.Dom (MonadWidget, Event)
-import qualified Reflex.Dom as R
-import Prelude hiding (init, error)
-
-import qualified Common.Message as Message
-import qualified Common.Message.Key as Key
-import Common.Model (InitResult(..), Init(..), User(..))
-import qualified Common.Model.User as User
-
-import Component.Button (ButtonIn(..))
-import qualified Component.Button as Component
-import qualified Icon
-
-data HeaderIn = HeaderIn
- { _headerIn_initResult :: InitResult
- }
-
-data HeaderOut t = HeaderOut
- { _headerOut_signOut :: Event t ()
- }
-
-view :: forall t m. MonadWidget t m => HeaderIn -> m (HeaderOut t)
-view headerIn =
- R.el "header" $ do
-
- R.divClass "title" $
- R.text $ Message.get Key.App_Title
-
- signOut <- nameSignOut $ _headerIn_initResult headerIn
-
- return $ HeaderOut
- { _headerOut_signOut = signOut
- }
-
-nameSignOut :: forall t m. MonadWidget t m => InitResult -> m (Event t ())
-nameSignOut initResult = case initResult of
- (InitSuccess 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 User.find (_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 <- Component.button $ ButtonIn
- { Component._buttonIn_class = "signOut item"
- , Component._buttonIn_content = Icon.signOut
- , Component._buttonIn_waiting = waiting
- }
- let signOutClic = Component._buttonOut_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 "/signOut" ()) signOut
- getResult = (== 200) . R._xhrResponse_status