aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--ISSUES.md3
-rw-r--r--client/client.cabal3
-rw-r--r--client/src/Model/Loadable.hs51
-rw-r--r--client/src/Util/Ajax.hs21
-rw-r--r--client/src/View/App.hs16
-rw-r--r--client/src/View/Header.hs2
-rw-r--r--client/src/View/Income/Form.hs4
-rw-r--r--client/src/View/Income/Header.hs11
-rw-r--r--client/src/View/Income/Income.hs73
-rw-r--r--client/src/View/Income/Init.hs11
-rw-r--r--client/src/View/Income/Table.hs17
-rw-r--r--client/src/View/Payment/Form.hs4
-rw-r--r--client/src/View/Payment/Header.hs6
-rw-r--r--client/src/View/Payment/Init.hs13
-rw-r--r--client/src/View/Payment/Payment.hs165
-rw-r--r--client/src/View/Payment/Table.hs21
-rw-r--r--client/src/View/SignIn.hs2
-rw-r--r--common/src/Common/Model/Init.hs22
-rw-r--r--server/server.cabal2
-rw-r--r--server/src/Controller/Category.hs9
-rw-r--r--server/src/Controller/Income.hs9
-rw-r--r--server/src/Controller/Index.hs11
-rw-r--r--server/src/Controller/Payment.hs7
-rw-r--r--server/src/Controller/User.hs17
-rw-r--r--server/src/Design/Global.hs12
-rw-r--r--server/src/Main.hs24
-rw-r--r--server/src/Persistence/Init.hs25
27 files changed, 391 insertions, 170 deletions
diff --git a/ISSUES.md b/ISSUES.md
index 56f158d..95b435a 100644
--- a/ISSUES.md
+++ b/ISSUES.md
@@ -1,6 +1,5 @@
## Income view
-- Take into account modified incomes into payment table
- Clone an income
- Edit an income
- Remove an income
@@ -15,7 +14,7 @@
## Mobile
-- Slow, consider native ?
+- Slow, consider native ? consider doing more work on the server ?
# Additional features
diff --git a/client/client.cabal b/client/client.cabal
index bfcfc59..9a0d24e 100644
--- a/client/client.cabal
+++ b/client/client.cabal
@@ -54,6 +54,8 @@ Executable client
Component.Table
Component.Select
Icon
+ Model.Loadable
+ Model.Route
Util.Ajax
Util.Css
Util.Date
@@ -77,6 +79,7 @@ Executable client
View.Payment.Edit
View.Payment.Form
View.Payment.Header
+ View.Payment.Init
View.Payment.Pages
View.Payment.Payment
View.Payment.Table
diff --git a/client/src/Model/Loadable.hs b/client/src/Model/Loadable.hs
new file mode 100644
index 0000000..3076b46
--- /dev/null
+++ b/client/src/Model/Loadable.hs
@@ -0,0 +1,51 @@
+module Model.Loadable
+ ( Loadable (..)
+ , fromEvent
+ , view
+ ) where
+
+import Reflex.Dom (MonadWidget)
+import qualified Reflex.Dom as R
+
+import Data.Functor (Functor)
+import Data.Text (Text)
+import Reflex.Dom (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+data Loadable t
+ = Loading
+ | Error Text
+ | Loaded t
+
+instance Functor Loadable where
+ fmap f Loading = Loading
+ fmap f (Error e) = Error e
+ fmap f (Loaded x) = Loaded (f x)
+
+instance Applicative Loadable where
+ pure x = Loaded x
+
+ Loading <*> _ = Loading
+ (Error e) <*> _ = Error e
+ (Loaded f) <*> Loading = Loading
+ (Loaded f) <*> (Error e) = Error e
+ (Loaded f) <*> (Loaded x) = Loaded (f x)
+
+instance Monad Loadable where
+ Loading >>= f = Loading
+ (Error e) >>= f = Error e
+ (Loaded x) >>= f = f x
+
+fromEvent :: forall t m a. MonadWidget t m => Event t (Either Text a) -> m (Dynamic t (Loadable a))
+fromEvent =
+ R.foldDyn
+ (\res _ -> case res of
+ Left err -> Error err
+ Right t -> Loaded t
+ )
+ Loading
+
+view :: forall t m a. MonadWidget t m => (a -> m ()) -> Loadable a -> m ()
+view _ (Loading) = R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank
+view _ (Error e) = R.text e
+view f (Loaded x) = f x
diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs
index a4f6a74..9cd5105 100644
--- a/client/src/Util/Ajax.hs
+++ b/client/src/Util/Ajax.hs
@@ -1,6 +1,7 @@
module Util.Ajax
- ( postJson
- , putJson
+ ( get
+ , post
+ , put
, delete
) where
@@ -20,21 +21,29 @@ import Reflex.Dom (Dynamic, Event, IsXhrPayload,
XhrResponseHeaders (..))
import qualified Reflex.Dom as R
-postJson
+get
+ :: forall t m a. (MonadWidget t m, FromJSON a)
+ => Event t Text
+ -> m (Event t (Either Text a))
+get url =
+ fmap getJsonResult <$>
+ R.performRequestAsync (R.ffor url $ \u -> jsonRequest "GET" u (Aeson.String ""))
+
+post
:: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b)
=> Text
-> Event t a
-> m (Event t (Either Text b))
-postJson url input =
+post url input =
fmap getJsonResult <$>
R.performRequestAsync (jsonRequest "POST" url <$> input)
-putJson
+put
:: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b)
=> Text
-> Event t a
-> m (Event t (Either Text b))
-putJson url input =
+put url input =
fmap getJsonResult <$>
R.performRequestAsync (jsonRequest "PUT" url <$> input)
diff --git a/client/src/View/App.hs b/client/src/View/App.hs
index 3292336..b468e56 100644
--- a/client/src/View/App.hs
+++ b/client/src/View/App.hs
@@ -7,7 +7,8 @@ import Prelude hiding (error, init)
import Reflex.Dom (Dynamic, MonadWidget)
import qualified Reflex.Dom as R
-import Common.Model (Init, InitResult (..))
+import Common.Model (Currency, Init (..), InitResult (..),
+ UserId)
import qualified Common.Msg as Msg
import Model.Route (Route (..))
@@ -60,14 +61,19 @@ widget initResult =
signedWidget :: MonadWidget t m => Init -> Dynamic t Route -> m ()
signedWidget init route = do
R.dyn . R.ffor route $ \case
- RootRoute ->
+ RootRoute -> do
+ paymentInit <- Payment.init
Payment.view $ PaymentIn
- { _paymentIn_init = init
+ { _paymentIn_currentUser = _init_currentUser init
+ , _paymentIn_currency = _init_currency init
+ , _paymentIn_init = paymentInit
}
- IncomeRoute ->
+ IncomeRoute -> do
+ incomeInit <- Income.init
Income.view $ IncomeIn
- { _incomeIn_init = init
+ { _incomeIn_currency = _init_currency init
+ , _incomeIn_init = incomeInit
}
NotFoundRoute ->
diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs
index 9a4de89..bd69e47 100644
--- a/client/src/View/Header.hs
+++ b/client/src/View/Header.hs
@@ -73,7 +73,7 @@ links route = do
nameSignOut :: forall t m. MonadWidget t m => InitResult -> m (Event t ())
nameSignOut initResult = case initResult of
- (InitSuccess init) -> do
+ InitSuccess init -> do
rec
attr <- R.holdDyn
(M.singleton "class" "nameSignOut")
diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs
index b8a9094..2bfc23f 100644
--- a/client/src/View/Income/Form.hs
+++ b/client/src/View/Income/Form.hs
@@ -109,5 +109,5 @@ view formIn = do
where
ajax =
case _formIn_httpMethod formIn of
- Post -> Ajax.postJson
- Put -> Ajax.putJson
+ Post -> Ajax.post
+ Put -> Ajax.put
diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs
index e384161..4e08955 100644
--- a/client/src/View/Income/Header.hs
+++ b/client/src/View/Income/Header.hs
@@ -11,19 +11,22 @@ import qualified Data.Time.Clock as Clock
import Reflex.Dom (Dynamic, Event, MonadWidget)
import qualified Reflex.Dom as R
-import Common.Model (Income (..), Init (..), User (..))
+import Common.Model (Currency, Income (..), User (..))
import qualified Common.Model as CM
import qualified Common.Msg as Msg
import qualified Common.View.Format as Format
+
import Component (ButtonOut (..))
import qualified Component
import qualified Component.Modal as Modal
import qualified Util.Date as DateUtil
import qualified View.Income.Add as Add
+import View.Income.Init (Init (..))
data HeaderIn t = HeaderIn
- { _headerIn_init :: Init
- , _headerIn_incomes :: Dynamic t [Income]
+ { _headerIn_init :: Init
+ , _headerIn_currency :: Currency
+ , _headerIn_incomes :: Dynamic t [Income]
}
data HeaderOut t = HeaderOut
@@ -55,7 +58,7 @@ view headerIn =
T.intercalate " "
[ _user_name user
, "−"
- , Format.price (_init_currency init) $
+ , Format.price (_headerIn_currency headerIn) $
CM.cumulativeIncomesSince currentTime since userIncomes
]
diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs
index 167aedf..91682a0 100644
--- a/client/src/View/Income/Income.hs
+++ b/client/src/View/Income/Income.hs
@@ -1,40 +1,73 @@
module View.Income.Income
- ( view
+ ( init
+ , view
, IncomeIn(..)
) where
+import Prelude hiding (init)
import Reflex.Dom (Dynamic, MonadWidget)
import qualified Reflex.Dom as R
-import Common.Model (Init (..))
+import Common.Model (Currency)
+
+import Model.Loadable (Loadable (..))
+import qualified Model.Loadable as Loadable
+import qualified Util.Ajax as AjaxUtil
import View.Income.Header (HeaderIn (..), HeaderOut (..))
import qualified View.Income.Header as Header
+import View.Income.Init (Init (..))
import View.Income.Table (IncomeTableIn (..))
import qualified View.Income.Table as Table
-data IncomeIn = IncomeIn
- { _incomeIn_init :: Init
+data IncomeIn t = IncomeIn
+ { _incomeIn_currency :: Currency
+ , _incomeIn_init :: Dynamic t (Loadable Init)
}
-view :: forall t m. MonadWidget t m => IncomeIn -> m ()
-view incomeIn =
- R.elClass "main" "income" $ do
+init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init))
+init = do
+ postBuild <- R.getPostBuild
+
+ usersEvent <- AjaxUtil.get (R.tag (R.constant "api/users") postBuild)
+ users <- Loadable.fromEvent usersEvent
+
+ incomesEvent <- AjaxUtil.get (R.tag (R.constant "api/incomes") postBuild)
+ incomes <- Loadable.fromEvent incomesEvent
+
+ paymentsEvent <- AjaxUtil.get (R.tag (R.constant "api/payments") postBuild)
+ payments <- Loadable.fromEvent paymentsEvent
+
+ return $ do
+ us <- users
+ is <- incomes
+ ps <- payments
+ return $ Init <$> us <*> is <*> ps
+
+view :: forall t m. MonadWidget t m => IncomeIn t -> m ()
+view incomeIn = do
+ R.dyn . R.ffor (_incomeIn_init incomeIn) . Loadable.view $ \init ->
+
+ R.elClass "main" "income" $ do
+
+ rec
- rec
+ incomes <- R.foldDyn
+ (:)
+ (_init_incomes init)
+ (_headerOut_addIncome header)
- incomes <- R.foldDyn
- (:)
- (_init_incomes . _incomeIn_init $ incomeIn)
- (_headerOut_addIncome header)
+ header <- Header.view $ HeaderIn
+ { _headerIn_init = init
+ , _headerIn_currency = _incomeIn_currency incomeIn
+ , _headerIn_incomes = incomes
+ }
- header <- Header.view $ HeaderIn
- { _headerIn_init = _incomeIn_init incomeIn
- , _headerIn_incomes = incomes
+ Table.view $ IncomeTableIn
+ { _tableIn_init = init
+ , _tableIn_currency = _incomeIn_currency incomeIn
+ , _tableIn_incomes = incomes
}
- Table.view $ IncomeTableIn
- { _tableIn_init = _incomeIn_init incomeIn
- , _tableIn_incomes = incomes
- }
+ return ()
- return ()
+ return ()
diff --git a/client/src/View/Income/Init.hs b/client/src/View/Income/Init.hs
new file mode 100644
index 0000000..4f3ef99
--- /dev/null
+++ b/client/src/View/Income/Init.hs
@@ -0,0 +1,11 @@
+module View.Income.Init
+ ( Init(..)
+ ) where
+
+import Common.Model (Income, Payment, User)
+
+data Init = Init
+ { _init_users :: [User]
+ , _init_incomes :: [Income]
+ , _init_payments :: [Payment]
+ } deriving (Show)
diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs
index 5363ca5..d42848b 100644
--- a/client/src/View/Income/Table.hs
+++ b/client/src/View/Income/Table.hs
@@ -9,16 +9,19 @@ import Data.Text (Text)
import Reflex.Dom (Dynamic, MonadWidget)
import qualified Reflex.Dom as R
-import Common.Model (Income (..), Init (..), User (..))
+import Common.Model (Currency, Income (..), User (..))
import qualified Common.Model as CM
import qualified Common.Msg as Msg
import qualified Common.View.Format as Format
+
import Component (TableIn (..))
import qualified Component
+import View.Income.Init (Init (..))
data IncomeTableIn t = IncomeTableIn
- { _tableIn_init :: Init
- , _tableIn_incomes :: Dynamic t [Income]
+ { _tableIn_init :: Init
+ , _tableIn_currency :: Currency
+ , _tableIn_incomes :: Dynamic t [Income]
}
view :: forall t m. MonadWidget t m => IncomeTableIn t -> m ()
@@ -27,7 +30,7 @@ view tableIn = do
Component.table $ TableIn
{ _tableIn_headerLabel = headerLabel
, _tableIn_rows = R.ffor (_tableIn_incomes tableIn) $ reverse . L.sortOn _income_date
- , _tableIn_cell = cell (_tableIn_init tableIn)
+ , _tableIn_cell = cell (_tableIn_init tableIn) (_tableIn_currency tableIn)
, _tableIn_perPage = 7
, _tableIn_resetPage = R.never
}
@@ -45,8 +48,8 @@ headerLabel UserHeader = Msg.get Msg.Income_Name
headerLabel DateHeader = Msg.get Msg.Income_Date
headerLabel AmountHeader = Msg.get Msg.Income_Amount
-cell :: Init -> Header -> Income -> Text
-cell init header income =
+cell :: Init -> Currency -> Header -> Income -> Text
+cell init currency header income =
case header of
UserHeader ->
Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) (_init_users init)
@@ -55,4 +58,4 @@ cell init header income =
Format.longDay . _income_date $ income
AmountHeader ->
- Format.price (_init_currency init) . _income_amount $ income
+ Format.price currency . _income_amount $ income
diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs
index 7819836..c817831 100644
--- a/client/src/View/Payment/Form.hs
+++ b/client/src/View/Payment/Form.hs
@@ -165,8 +165,8 @@ view input = do
ajax =
case _input_httpMethod input of
- Post -> Ajax.postJson
- Put -> Ajax.putJson
+ Post -> Ajax.post
+ Put -> Ajax.put
findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId
findCategory paymentName =
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index 9db4c7c..9ad90a9 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -20,7 +20,7 @@ import qualified Reflex.Dom as R
import Common.Model (Category, Currency,
ExceedingPayer (..), Frequency (..),
- Income (..), Init (..), Payment (..),
+ Income (..), Payment (..),
PaymentCategory, SavedPayment (..),
User (..))
import qualified Common.Model as CM
@@ -34,9 +34,11 @@ import qualified Component as Component
import qualified Component.Modal as Modal
import qualified Util.List as L
import qualified View.Payment.Add as Add
+import View.Payment.Init (Init (..))
data HeaderIn t = HeaderIn
{ _headerIn_init :: Init
+ , _headerIn_currency :: Currency
, _headerIn_payments :: Dynamic t [Payment]
, _headerIn_searchPayments :: Dynamic t [Payment]
, _headerIn_paymentCategories :: Dynamic t [PaymentCategory]
@@ -78,7 +80,7 @@ widget headerIn =
payments = _headerIn_payments headerIn
users = _init_users init
categories = _init_categories init
- currency = _init_currency init
+ currency = _headerIn_currency headerIn
paymentCategories = _headerIn_paymentCategories headerIn
payerAndAdd
diff --git a/client/src/View/Payment/Init.hs b/client/src/View/Payment/Init.hs
new file mode 100644
index 0000000..d9f85c8
--- /dev/null
+++ b/client/src/View/Payment/Init.hs
@@ -0,0 +1,13 @@
+module View.Payment.Init
+ ( Init(..)
+ ) where
+
+import Common.Model (Category, Income, Payment, PaymentCategory, User)
+
+data Init = Init
+ { _init_users :: [User]
+ , _init_payments :: [Payment]
+ , _init_incomes :: [Income]
+ , _init_categories :: [Category]
+ , _init_paymentCategories :: [PaymentCategory]
+ } deriving (Show)
diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs
index cfdb441..ec350e2 100644
--- a/client/src/View/Payment/Payment.hs
+++ b/client/src/View/Payment/Payment.hs
@@ -1,5 +1,6 @@
module View.Payment.Payment
- ( view
+ ( init
+ , view
, PaymentIn(..)
) where
@@ -10,78 +11,118 @@ import Prelude hiding (init)
import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex)
import qualified Reflex.Dom as R
-import Common.Model (Frequency, Init (..), Payment (..),
- PaymentCategory (..), PaymentId,
- SavedPayment (..))
+import Common.Model (Currency, Frequency, Income (..),
+ Payment (..), PaymentCategory (..),
+ PaymentId, SavedPayment (..), User,
+ UserId)
import qualified Common.Util.Text as T
+
+import Model.Loadable (Loadable (..))
+import qualified Model.Loadable as Loadable
+import qualified Util.Ajax as AjaxUtil
import View.Payment.Header (HeaderIn (..), HeaderOut (..))
import qualified View.Payment.Header as Header
+import View.Payment.Init (Init (..))
import View.Payment.Pages (PagesIn (..), PagesOut (..))
import qualified View.Payment.Pages as Pages
import View.Payment.Table (TableIn (..), TableOut (..))
import qualified View.Payment.Table as Table
-data PaymentIn = PaymentIn
- { _paymentIn_init :: Init
+init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init))
+init = do
+ postBuild <- R.getPostBuild
+
+ incomesEvent <- AjaxUtil.get (R.tag (R.constant "api/incomes") postBuild)
+ incomes <- Loadable.fromEvent incomesEvent
+
+ usersEvent <- AjaxUtil.get (R.tag (R.constant "api/users") postBuild)
+ users <- Loadable.fromEvent usersEvent
+
+ paymentsEvent <- AjaxUtil.get (R.tag (R.constant "api/payments") postBuild)
+ payments <- Loadable.fromEvent paymentsEvent
+
+ paymentCategoriesEvent <- AjaxUtil.get (R.tag (R.constant "api/paymentCategories") postBuild)
+ paymentCategories <- Loadable.fromEvent paymentCategoriesEvent
+
+ categoriesEvent <- AjaxUtil.get (R.tag (R.constant "api/categories") postBuild)
+ categories <- Loadable.fromEvent categoriesEvent
+
+ return $ do
+ us <- users
+ ps <- payments
+ is <- incomes
+ cs <- categories
+ pcs <- paymentCategories
+ return $ Init <$> us <*> ps <*> is <*> cs <*> pcs
+
+data PaymentIn t = PaymentIn
+ { _paymentIn_currentUser :: UserId
+ , _paymentIn_currency :: Currency
+ , _paymentIn_init :: Dynamic t (Loadable Init)
}
-view :: forall t m. MonadWidget t m => PaymentIn -> m ()
+view :: forall t m. MonadWidget t m => PaymentIn t -> m ()
view paymentIn = do
- R.elClass "main" "payment" $ do
- rec
- let init = _paymentIn_init paymentIn
-
- paymentsPerPage = 7
-
- addPayment = R.leftmost
- [ _headerOut_addPayment header
- , _tableOut_addPayment table
- ]
-
- payments <- reducePayments
- (_init_payments init)
- (_savedPayment_payment <$> addPayment)
- (_savedPayment_payment <$> _tableOut_editPayment table)
- (_tableOut_deletePayment table)
-
- paymentCategories <- reducePaymentCategories
- (_init_paymentCategories init)
- payments
- (_savedPayment_paymentCategory <$> addPayment)
- (_savedPayment_paymentCategory <$> _tableOut_editPayment table)
- (_tableOut_deletePayment table)
-
- (searchNameEvent, searchName) <-
- debounceSearchName (_headerOut_searchName header)
-
- let searchPayments =
- getSearchPayments searchName (_headerOut_searchFrequency header) payments
-
- header <- Header.widget $ HeaderIn
- { _headerIn_init = init
- , _headerIn_payments = payments
- , _headerIn_searchPayments = searchPayments
- , _headerIn_paymentCategories = paymentCategories
- }
-
- table <- Table.widget $ TableIn
- { _tableIn_init = init
- , _tableIn_currentPage = _pagesOut_currentPage pages
- , _tableIn_payments = searchPayments
- , _tableIn_perPage = paymentsPerPage
- , _tableIn_paymentCategories = paymentCategories
- }
-
- pages <- Pages.widget $ PagesIn
- { _pagesIn_total = length <$> searchPayments
- , _pagesIn_perPage = paymentsPerPage
- , _pagesIn_reset = R.leftmost $
- [ () <$ searchNameEvent
- , () <$ _headerOut_addPayment header
- ]
- }
-
- pure ()
+ R.dyn . R.ffor (_paymentIn_init paymentIn) . Loadable.view $ \init ->
+
+ R.elClass "main" "payment" $ do
+ rec
+ let addPayment = R.leftmost
+ [ _headerOut_addPayment header
+ , _tableOut_addPayment table
+ ]
+
+ paymentsPerPage = 7
+
+ payments <- reducePayments
+ (_init_payments init)
+ (_savedPayment_payment <$> addPayment)
+ (_savedPayment_payment <$> _tableOut_editPayment table)
+ (_tableOut_deletePayment table)
+
+ paymentCategories <- reducePaymentCategories
+ (_init_paymentCategories init)
+ payments
+ (_savedPayment_paymentCategory <$> addPayment)
+ (_savedPayment_paymentCategory <$> _tableOut_editPayment table)
+ (_tableOut_deletePayment table)
+
+ (searchNameEvent, searchName) <-
+ debounceSearchName (_headerOut_searchName header)
+
+ let searchPayments =
+ getSearchPayments searchName (_headerOut_searchFrequency header) payments
+
+ header <- Header.widget $ HeaderIn
+ { _headerIn_init = init
+ , _headerIn_currency = _paymentIn_currency paymentIn
+ , _headerIn_payments = payments
+ , _headerIn_searchPayments = searchPayments
+ , _headerIn_paymentCategories = paymentCategories
+ }
+
+ table <- Table.widget $ TableIn
+ { _tableIn_init = init
+ , _tableIn_currency = _paymentIn_currency paymentIn
+ , _tableIn_currentUser = _paymentIn_currentUser paymentIn
+ , _tableIn_currentPage = _pagesOut_currentPage pages
+ , _tableIn_payments = searchPayments
+ , _tableIn_perPage = paymentsPerPage
+ , _tableIn_paymentCategories = paymentCategories
+ }
+
+ pages <- Pages.widget $ PagesIn
+ { _pagesIn_total = length <$> searchPayments
+ , _pagesIn_perPage = paymentsPerPage
+ , _pagesIn_reset = R.leftmost $
+ [ () <$ searchNameEvent
+ , () <$ _headerOut_addPayment header
+ ]
+ }
+
+ pure ()
+
+ return ()
debounceSearchName
:: forall t m. MonadWidget t m
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index bf6b604..5ffa037 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -13,10 +13,10 @@ import Prelude hiding (init)
import Reflex.Dom (Dynamic, Event, MonadWidget)
import qualified Reflex.Dom as R
-import Common.Model (Category (..), Frequency (Punctual),
- Init (..), Payment (..),
+import Common.Model (Category (..), Currency,
+ Frequency (Punctual), Payment (..),
PaymentCategory (..), SavedPayment,
- User (..))
+ User (..), UserId)
import qualified Common.Model as CM
import qualified Common.Msg as Msg
import qualified Common.View.Format as Format
@@ -26,12 +26,15 @@ import qualified Component.Modal as Modal
import qualified View.Payment.Clone as Clone
import qualified View.Payment.Delete as Delete
import qualified View.Payment.Edit as Edit
+import View.Payment.Init (Init (..))
import qualified Icon
import qualified Util.Reflex as ReflexUtil
data TableIn t = TableIn
{ _tableIn_init :: Init
+ , _tableIn_currency :: Currency
+ , _tableIn_currentUser :: UserId
, _tableIn_currentPage :: Dynamic t Int
, _tableIn_payments :: Dynamic t [Payment]
, _tableIn_perPage :: Int
@@ -61,7 +64,7 @@ widget tableIn = do
R.divClass "cell" $ R.blank
result <-
- (R.simpleList paymentRange (paymentRow init paymentCategories))
+ (R.simpleList paymentRange (paymentRow init currency currentUser paymentCategories))
return $
( R.switch . R.current . fmap (R.leftmost . map (\(a, _, _) -> a)) $ result
@@ -80,6 +83,8 @@ widget tableIn = do
where
init = _tableIn_init tableIn
+ currency = _tableIn_currency tableIn
+ currentUser = _tableIn_currentUser tableIn
currentPage = _tableIn_currentPage tableIn
payments = _tableIn_payments tableIn
paymentRange = getPaymentRange (_tableIn_perPage tableIn) <$> payments <*> currentPage
@@ -96,17 +101,19 @@ getPaymentRange perPage payments currentPage =
paymentRow
:: forall t m. MonadWidget t m
=> Init
+ -> Currency
+ -> UserId
-> Dynamic t [PaymentCategory]
-> Dynamic t Payment
-> m (Event t SavedPayment, Event t SavedPayment, Event t Payment)
-paymentRow init paymentCategories payment =
+paymentRow init currency currentUser paymentCategories payment =
R.divClass "row" $ do
R.divClass "cell name" $
R.dynText $ fmap _payment_name payment
R.divClass "cell cost" $
- R.dynText $ fmap (Format.price (_init_currency init) . _payment_cost) payment
+ R.dynText $ fmap (Format.price currency . _payment_cost) payment
let user = R.ffor payment (\p ->
CM.findUser (_payment_user p) (_init_users init))
@@ -162,7 +169,7 @@ paymentRow init paymentCategories payment =
let isFromCurrentUser =
R.ffor
payment
- (\p -> _payment_user p == _init_currentUser init)
+ (\p -> _payment_user p == currentUser)
editPayment <-
R.divClass "cell button" $
diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs
index 8c248bd..4fe495b 100644
--- a/client/src/View/SignIn.hs
+++ b/client/src/View/SignIn.hs
@@ -50,7 +50,7 @@ view signInMessage =
let form = SignInForm <$> _inputOut_raw input
(signInResult, waiting) <- WaitFor.waitFor
- (Ajax.postJson "/api/askSignIn")
+ (Ajax.post "/api/askSignIn")
(ValidationUtil.fireMaybe
((\f -> f <$ SignInValidation.signIn f) <$> form)
validate)
diff --git a/common/src/Common/Model/Init.hs b/common/src/Common/Model/Init.hs
index 68b3f5d..5ef1535 100644
--- a/common/src/Common/Model/Init.hs
+++ b/common/src/Common/Model/Init.hs
@@ -2,24 +2,16 @@ module Common.Model.Init
( Init(..)
) where
-import Data.Aeson (FromJSON, ToJSON)
-import GHC.Generics (Generic)
+import Data.Aeson (FromJSON, ToJSON)
+import GHC.Generics (Generic)
-import Common.Model.Category (Category)
-import Common.Model.Currency (Currency)
-import Common.Model.Income (Income)
-import Common.Model.Payment (Payment)
-import Common.Model.PaymentCategory (PaymentCategory)
-import Common.Model.User (User, UserId)
+import Common.Model.Currency (Currency)
+import Common.Model.User (User, UserId)
data Init = Init
- { _init_users :: [User]
- , _init_currentUser :: UserId
- , _init_payments :: [Payment]
- , _init_incomes :: [Income]
- , _init_categories :: [Category]
- , _init_paymentCategories :: [PaymentCategory]
- , _init_currency :: Currency
+ { _init_users :: [User]
+ , _init_currentUser :: UserId
+ , _init_currency :: Currency
} deriving (Show, Generic)
instance FromJSON Init
diff --git a/server/server.cabal b/server/server.cabal
index 022d496..eeba14f 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -62,6 +62,7 @@ Executable server
Controller.Income
Controller.Index
Controller.Payment
+ Controller.User
Cookie
Design.Color
Design.Constants
@@ -107,7 +108,6 @@ Executable server
Persistence.Category
Persistence.Frequency
Persistence.Income
- Persistence.Init
Persistence.Payment
Persistence.PaymentCategory
Persistence.User
diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs
index 37b8357..e536caa 100644
--- a/server/src/Controller/Category.hs
+++ b/server/src/Controller/Category.hs
@@ -1,5 +1,6 @@
module Controller.Category
- ( create
+ ( list
+ , create
, edit
, delete
) where
@@ -19,6 +20,12 @@ import qualified Persistence.Category as CategoryPersistence
import qualified Persistence.PaymentCategory as PaymentCategoryPersistence
import qualified Secure
+list :: ActionM ()
+list =
+ Secure.loggedAction (\_ ->
+ (liftIO . Query.run $ CategoryPersistence.list) >>= json
+ )
+
create :: CreateCategory -> ActionM ()
create (CreateCategory name color) =
Secure.loggedAction (\_ ->
diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs
index e013849..b40976b 100644
--- a/server/src/Controller/Income.hs
+++ b/server/src/Controller/Income.hs
@@ -1,5 +1,6 @@
module Controller.Income
- ( create
+ ( list
+ , create
, edit
, delete
) where
@@ -20,6 +21,12 @@ import qualified Persistence.Income as IncomePersistence
import qualified Secure
import qualified Validation.Income as IncomeValidation
+list :: ActionM ()
+list =
+ Secure.loggedAction (\_ ->
+ (liftIO . Query.run $ IncomePersistence.list) >>= json
+ )
+
create :: CreateIncomeForm -> ActionM ()
create form =
Secure.loggedAction (\user ->
diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs
index 5ebe921..3788685 100644
--- a/server/src/Controller/Index.hs
+++ b/server/src/Controller/Index.hs
@@ -16,8 +16,9 @@ import Prelude hiding (error)
import Web.Scotty (ActionM)
import qualified Web.Scotty as S
-import Common.Model (Email (..), InitResult (..),
- SignInForm (..), User (..))
+import Common.Model (Email (..), Init (..),
+ InitResult (..), SignInForm (..),
+ User (..))
import Common.Msg (Key)
import qualified Common.Msg as Msg
import qualified Common.Validation.SignIn as SignInValidation
@@ -26,7 +27,6 @@ import Conf (Conf (..))
import qualified LoginSession
import qualified Model.Query as Query
import qualified Model.SignIn as SignIn
-import qualified Persistence.Init as InitPersistence
import qualified Persistence.User as UserPersistence
import qualified Secure
import qualified SendMail
@@ -40,8 +40,9 @@ get conf = do
case mbLoggedUser of
Nothing ->
return InitEmpty
- Just user ->
- liftIO . Query.run . fmap InitSuccess $ InitPersistence.getInit user conf
+ Just user -> do
+ users <- liftIO . Query.run $ UserPersistence.list
+ return . InitSuccess $ Init users (_user_id user) (Conf.currency conf)
S.html $ page initResult
askSignIn :: Conf -> SignInForm -> ActionM ()
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index ba9d1ba..30b63ff 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -1,5 +1,6 @@
module Controller.Payment
( list
+ , listPaymentCategories
, create
, edit
, delete
@@ -32,6 +33,12 @@ list =
(liftIO . Query.run $ PaymentPersistence.listActive) >>= json
)
+listPaymentCategories :: ActionM ()
+listPaymentCategories =
+ Secure.loggedAction (\_ ->
+ (liftIO . Query.run $ PaymentCategoryPersistence.list) >>= json
+ )
+
create :: CreatePaymentForm -> ActionM ()
create form =
Secure.loggedAction (\user ->
diff --git a/server/src/Controller/User.hs b/server/src/Controller/User.hs
new file mode 100644
index 0000000..a7bb136
--- /dev/null
+++ b/server/src/Controller/User.hs
@@ -0,0 +1,17 @@
+module Controller.User
+ ( list
+ ) where
+
+import Control.Monad.IO.Class (liftIO)
+import Web.Scotty (ActionM)
+import qualified Web.Scotty as S
+
+import qualified Model.Query as Query
+import qualified Persistence.User as UserPersistence
+import qualified Secure
+
+list :: ActionM ()
+list =
+ Secure.loggedAction (\_ ->
+ (liftIO . Query.run $ UserPersistence.list) >>= S.json
+ )
diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs
index 5b8f2dc..598319b 100644
--- a/server/src/Design/Global.hs
+++ b/server/src/Design/Global.hs
@@ -52,6 +52,18 @@ global = do
".app" ? do
appearAnimation
+ display flex
+ height (pct 100)
+ flexDirection column
+
+ "main" ?
+ appearAnimation
+
+ ".pageSpinner" ? do
+ display flex
+ alignItems center
+ justifyContent center
+ flexGrow 1
".spinner" ? do
display flex
diff --git a/server/src/Main.hs b/server/src/Main.hs
index e3dad9e..9882092 100644
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@@ -1,3 +1,8 @@
+module Main
+ ( main
+ ) where
+
+import qualified Network.HTTP.Types.Status as Status
import Network.Wai.Middleware.Gzip (GzipFiles (GzipCompress))
import qualified Network.Wai.Middleware.Gzip as W
import Network.Wai.Middleware.Static
@@ -8,6 +13,7 @@ import qualified Controller.Category as Category
import qualified Controller.Income as Income
import qualified Controller.Index as Index
import qualified Controller.Payment as Payment
+import qualified Controller.User as User
import Job.Daemon (runDaemons)
main :: IO ()
@@ -32,6 +38,12 @@ main = do
S.post "/api/signOut" $
Index.signOut conf
+ S.get "/api/users"$
+ User.list
+
+ S.get "/api/payments" $
+ Payment.list
+
S.post "/api/payment" $
S.jsonData >>= Payment.create
@@ -42,6 +54,9 @@ main = do
paymentId <- S.param "id"
Payment.delete paymentId
+ S.get "/api/incomes" $
+ Income.list
+
S.post "/api/income" $
S.jsonData >>= Income.create
@@ -52,6 +67,12 @@ main = do
incomeId <- S.param "id"
Income.delete incomeId
+ S.get "/api/paymentCategories" $
+ Payment.listPaymentCategories
+
+ S.get "/api/categories" $
+ Category.list
+
S.post "/api/category" $
S.jsonData >>= Category.create
@@ -62,5 +83,6 @@ main = do
categoryId <- S.param "id"
Category.delete categoryId
- S.notFound $
+ S.notFound $ do
+ S.status Status.ok200
Index.get conf
diff --git a/server/src/Persistence/Init.hs b/server/src/Persistence/Init.hs
deleted file mode 100644
index 74d9172..0000000
--- a/server/src/Persistence/Init.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-module Persistence.Init
- ( getInit
- ) where
-
-import Common.Model (Init (Init), User (..))
-
-import Conf (Conf)
-import qualified Conf
-import Model.Query (Query)
-import qualified Persistence.Category as CategoryPersistence
-import qualified Persistence.Income as IncomePersistence
-import qualified Persistence.Payment as PaymentPersistence
-import qualified Persistence.PaymentCategory as PaymentCategoryPersistence
-import qualified Persistence.User as UserPersistence
-
-getInit :: User -> Conf -> Query Init
-getInit user conf =
- Init <$>
- UserPersistence.list <*>
- (return . _user_id $ user) <*>
- PaymentPersistence.listActive <*>
- IncomePersistence.list <*>
- CategoryPersistence.list <*>
- PaymentCategoryPersistence.list <*>
- (return . Conf.currency $ conf)