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
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
|
module View.Header
( view
, HeaderIn(..)
, HeaderOut(..)
) where
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 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 t) -> m (HeaderOut t)
view headerIn =
R.el "header" $ do
R.divClass "title" $
R.text $ Msg.get Msg.App_Title
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
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 <- Component.button $
(Component.defaultButtonIn Icon.signOut)
{ _buttonIn_class = R.constDyn "signOut item"
, _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 "/api/signOut" ()) signOut
getResult = (== 200) . R._xhrResponse_status
|
