aboutsummaryrefslogtreecommitdiff
path: root/src/client/View
diff options
context:
space:
mode:
Diffstat (limited to 'src/client/View')
-rw-r--r--src/client/View/App.hs44
-rw-r--r--src/client/View/Header.hs86
-rw-r--r--src/client/View/Payment.hs33
-rw-r--r--src/client/View/Payment/Table.hs90
-rw-r--r--src/client/View/SignIn.hs86
5 files changed, 0 insertions, 339 deletions
diff --git a/src/client/View/App.hs b/src/client/View/App.hs
deleted file mode 100644
index 1466811..0000000
--- a/src/client/View/App.hs
+++ /dev/null
@@ -1,44 +0,0 @@
-{-# 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/src/client/View/Header.hs b/src/client/View/Header.hs
deleted file mode 100644
index 32738f1..0000000
--- a/src/client/View/Header.hs
+++ /dev/null
@@ -1,86 +0,0 @@
-{-# 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.User as User
-
-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 User.find (_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/src/client/View/Payment.hs b/src/client/View/Payment.hs
deleted file mode 100644
index e80790b..0000000
--- a/src/client/View/Payment.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-{-# 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/src/client/View/Payment/Table.hs b/src/client/View/Payment/Table.hs
deleted file mode 100644
index 878e7da..0000000
--- a/src/client/View/Payment/Table.hs
+++ /dev/null
@@ -1,90 +0,0 @@
-{-# 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.User as User
-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 User.find (_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/src/client/View/SignIn.hs b/src/client/View/SignIn.hs
deleted file mode 100644
index e164ee7..0000000
--- a/src/client/View/SignIn.hs
+++ /dev/null
@@ -1,86 +0,0 @@
-{-# 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-09-27 13:18:57 +0000