Use a better project structure

1 files changed, 86 insertions, 0 deletions

diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs
new file mode 100644
index 0000000..705e054
--- /dev/null
+++ b/client/src/View/Header.hs
@@ -0,0 +1,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 as CM
+
+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 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 $ 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