aboutsummaryrefslogtreecommitdiff
path: root/client/src/View
diff options
context:
space:
mode:
Diffstat (limited to 'client/src/View')
-rw-r--r--client/src/View/App.hs44
-rw-r--r--client/src/View/Header.hs86
-rw-r--r--client/src/View/Payment.hs33
-rw-r--r--client/src/View/Payment/Table.hs90
-rw-r--r--client/src/View/SignIn.hs86
5 files changed, 339 insertions, 0 deletions
diff --git a/client/src/View/App.hs b/client/src/View/App.hs
new file mode 100644
index 0000000..1466811
--- /dev/null
+++ b/client/src/View/App.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecursiveDo #-}
+
+module View.App
+ ( widget
+ ) where
+
+import qualified Reflex.Dom as R
+import Prelude hiding (init, error)
+
+import Common.Model (InitResult(..))
+import qualified Common.Message as Message
+import qualified Common.Message.Key as Key
+
+import View.Header (HeaderIn(..))
+import View.Payment (PaymentIn(..))
+import qualified View.Header as Header
+import qualified View.Payment as Payment
+import qualified View.SignIn as SignIn
+
+widget :: InitResult -> IO ()
+widget initResult =
+ R.mainWidget $ do
+ headerOut <- Header.view $ HeaderIn
+ { _headerIn_initResult = initResult
+ }
+
+ let signOut = Header._headerOut_signOut headerOut
+
+ initialContent = case initResult of
+ InitSuccess initSuccess -> do
+ _ <- Payment.widget $ PaymentIn
+ { _paymentIn_init = initSuccess
+ }
+ return ()
+ InitEmpty result ->
+ SignIn.view result
+
+ signOutContent = SignIn.view (Right . Just $ Message.get Key.SignIn_DisconnectSuccess)
+
+ _ <- R.widgetHold initialContent (fmap (const signOutContent) signOut)
+
+ R.blank
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
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
new file mode 100644
index 0000000..e80790b
--- /dev/null
+++ b/client/src/View/Payment.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecursiveDo #-}
+
+module View.Payment
+ ( widget
+ , PaymentIn(..)
+ , PaymentOut(..)
+ ) where
+
+import Reflex.Dom (MonadWidget)
+import qualified Reflex.Dom as R
+
+import Common.Model (Init)
+
+import View.Payment.Table (TableIn(..))
+import qualified View.Payment.Table as Table
+
+data PaymentIn = PaymentIn
+ { _paymentIn_init :: Init
+ }
+
+data PaymentOut = PaymentOut
+ {
+ }
+
+widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut
+widget paymentIn = do
+ R.divClass "payment" $ do
+ _ <- Table.widget $ TableIn
+ { _tableIn_init = _paymentIn_init paymentIn
+ }
+ return $ PaymentOut {}
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
new file mode 100644
index 0000000..f3eb9a7
--- /dev/null
+++ b/client/src/View/Payment/Table.hs
@@ -0,0 +1,90 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecursiveDo #-}
+
+module View.Payment.Table
+ ( widget
+ , TableIn(..)
+ , TableOut(..)
+ ) where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.List as L
+import qualified Data.Map as M
+import Prelude hiding (init)
+import Reflex.Dom (MonadWidget)
+import qualified Reflex.Dom as R
+
+import qualified Common.Message as Message
+import qualified Common.Message.Key as Key
+import Common.Model (Payment(..), PaymentCategory(..), Category(..), User(..), Init(..))
+import qualified Common.Model as CM
+import qualified Common.Util.Text as T
+import qualified Common.View.Format as Format
+
+import qualified Icon
+
+data TableIn = TableIn
+ { _tableIn_init :: Init
+ }
+
+data TableOut = TableOut
+ {
+ }
+
+widget :: forall t m. MonadWidget t m => TableIn -> m TableOut
+widget tableIn = do
+ R.divClass "table" $
+ R.divClass "lines" $ do
+ R.divClass "header" $ do
+ R.divClass "cell name" $ R.text $ Message.get Key.Payment_Name
+ R.divClass "cell cost" $ R.text $ Message.get Key.Payment_Cost
+ R.divClass "cell user" $ R.text $ Message.get Key.Payment_User
+ R.divClass "cell category" $ R.text $ Message.get Key.Payment_Category
+ R.divClass "cell date" $ R.text $ Message.get Key.Payment_Date
+ R.divClass "cell" $ R.blank
+ R.divClass "cell" $ R.blank
+ R.divClass "cell" $ R.blank
+ let init = _tableIn_init tableIn
+ payments = _init_payments init
+ mapM_
+ (paymentRow init)
+ (take 8 . reverse . L.sortOn _payment_date $ payments)
+ return $ TableOut {}
+
+paymentRow :: forall t m. MonadWidget t m => Init -> Payment -> m ()
+paymentRow init payment =
+ R.divClass "row" $ do
+ R.divClass "cell name" . R.text $ _payment_name payment
+ R.divClass "cell cost" . R.text . Format.price (_init_currency init) $ _payment_cost payment
+ R.divClass "cell user" $
+ case CM.findUser (_payment_user payment) (_init_users init) of
+ Just user -> R.text (_user_name user)
+ _ -> R.blank
+ R.divClass "cell category" $
+ case findCategory (_init_categories init) (_init_paymentCategories init) (_payment_name payment) of
+ Just category ->
+ R.elAttr "span" (M.fromList [("class", "tag"), ("style", T.concat [ "background-color: ", _category_color category ])]) $
+ R.text $ _category_name category
+ _ ->
+ R.blank
+ R.divClass "cell date" $ do
+ R.elClass "span" "shortDate" . R.text $ Format.shortDay (_payment_date payment)
+ R.elClass "span" "longDate" . R.text $ Format.longDay (_payment_date payment)
+ R.divClass "cell button" . R.el "button" $ Icon.clone
+ R.divClass "cell button" $
+ if _payment_user payment == (_init_currentUser init)
+ then R.el "button" $ Icon.edit
+ else R.blank
+ R.divClass "cell button" $
+ if _payment_user payment == (_init_currentUser init)
+ then R.el "button" $ Icon.delete
+ else R.blank
+
+findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category
+findCategory categories paymentCategories paymentName = do
+ paymentCategory <- L.find
+ ((== (T.unaccent . T.toLower) paymentName) . _paymentCategory_name)
+ paymentCategories
+ L.find ((== (_paymentCategory_category paymentCategory)) . _category_id) categories
diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs
new file mode 100644
index 0000000..e164ee7
--- /dev/null
+++ b/client/src/View/SignIn.hs
@@ -0,0 +1,86 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecursiveDo #-}
+
+module View.SignIn
+ ( view
+ ) where
+
+import qualified Data.Either as Either
+import Data.Monoid ((<>))
+import Data.Text (Text)
+import Data.Time (NominalDiffTime)
+import Prelude hiding (error)
+import Reflex.Dom (MonadWidget, Event)
+import qualified Reflex.Dom as R
+
+import qualified Common.Message as Message
+import qualified Common.Message.Key as Key
+import Common.Model (SignIn(SignIn))
+
+import Component.Input (InputIn(..), InputOut(..))
+import Component.Button (ButtonIn(..), ButtonOut(..))
+import qualified Component.Button as Component
+import qualified Component.Input as Component
+
+view :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> m ()
+view result =
+ R.divClass "signIn" $ do
+ rec
+ input <- Component.input $ InputIn
+ { _inputIn_reset = R.ffilter Either.isRight signInResult
+ , _inputIn_placeHolder = Message.get Key.SignIn_EmailPlaceholder
+ }
+
+ let userWantsEmailValidation = _inputOut_enter input <> _buttonOut_clic button
+
+ dynValidatedEmail <- R.holdDyn False . R.mergeWith (\_ _ -> False) $
+ [ fmap (const True) userWantsEmailValidation
+ , fmap (const False) signInResult
+ ]
+
+ uniqDynValidatedEmail <- R.holdUniqDyn dynValidatedEmail
+
+ let validatedEmail = R.tagPromptlyDyn
+ (_inputOut_value input)
+ (R.ffilter (== True) . R.updated $ uniqDynValidatedEmail)
+
+ let waiting = R.leftmost
+ [ fmap (const True) validatedEmail
+ , fmap (const False) signInResult
+ ]
+
+ button <- Component.button $ ButtonIn
+ { _buttonIn_class = ""
+ , _buttonIn_content = R.text (Message.get Key.SignIn_Button)
+ , _buttonIn_waiting = waiting
+ }
+
+ signInResult <- askSignIn validatedEmail >>= R.debounce (0.5 :: NominalDiffTime)
+
+ showSignInResult result signInResult
+
+askSignIn :: forall t m. MonadWidget t m => Event t Text -> m (Event t (Either Text Text))
+askSignIn email =
+ fmap getResult <$> R.performRequestAsync xhrRequest
+ where xhrRequest = fmap (R.postJson "/signIn" . SignIn) email
+ getResult response =
+ case R._xhrResponse_responseText response of
+ Just key ->
+ if R._xhrResponse_status response == 200 then Right key else Left key
+ _ -> Left "NoKey"
+
+showSignInResult :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> Event t (Either Text Text) -> m ()
+showSignInResult result signInResult = do
+ _ <- R.widgetHold (showInitResult result) $ R.ffor signInResult showResult
+ R.blank
+
+ where showInitResult (Left error) = showError error
+ showInitResult (Right (Just success)) = showSuccess success
+ showInitResult (Right Nothing) = R.blank
+
+ showResult (Left error) = showError error
+ showResult (Right success) = showSuccess success
+
+ showError = R.divClass "error" . R.text
+ showSuccess = R.divClass "success" . R.text
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-23 03:00:36 +0000