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
, In(..)
, Out(..)
) 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 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_initResult :: InitResult
, _in_isInitSuccess :: Bool
, _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
signOut <- R.el "div" $ do
rec
showLinks <- R.foldDyn const (_in_isInitSuccess input) (False <$ signOut)
ReflexUtil.visibleIfDyn showLinks R.blank (links $ _in_route input)
signOut <- nameSignOut $ _in_initResult input
return signOut
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)
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 <- 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
|
