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
114
115
116
117
118
119
120
121
122
123
|
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
|
