blob: 32738f17588315d8b8b7f39f5983a0314c82af03 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
|
{-# 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
|
