blob: 8f1fb789187c3ef77eeac042ddddf58ce85e6440 (
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
|
module View.Header
( view
, HeaderIn(..)
, HeaderOut(..)
) where
import qualified Data.Map as M
import Data.Time (NominalDiffTime)
import Prelude hiding (error, init)
import Reflex.Dom (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 as Component
import Component.Button (ButtonIn (..))
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 $ Msg.get Msg.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 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 "/signOut" ()) signOut
getResult = (== 200) . R._xhrResponse_status
|
