aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--README.md20
-rw-r--r--client/src/Component/Input.hs4
-rw-r--r--client/src/View/Payment.hs30
-rw-r--r--client/src/View/Payment/Add.hs22
-rw-r--r--client/src/View/Payment/Header.hs22
-rw-r--r--client/src/View/Payment/Table.hs31
-rw-r--r--common/common.cabal1
-rw-r--r--common/src/Common/Model.hs1
-rw-r--r--common/src/Common/Model/CreatedPayment.hs17
-rw-r--r--server/src/Controller/Payment.hs6
-rw-r--r--server/src/Persistence/PaymentCategory.hs48
11 files changed, 130 insertions, 72 deletions
diff --git a/README.md b/README.md
index 83a172c..a102f87 100644
--- a/README.md
+++ b/README.md
@@ -1,5 +1,4 @@
-Shared Cost
-===========
+# Shared Cost
Share costs with a group of people:
@@ -8,8 +7,7 @@ Share costs with a group of people:
- Statistics by month,
- Weekly activity sent by email.
-Getting started
----------------
+## Getting started
Install nix:
@@ -43,20 +41,22 @@ Later, stop the environment with:
./make stop
```
-Dist
-----
+## Dist
```
make dist
```
-Configuration
--------------
+## Configuration
See [application.conf](application.conf).
-TODO
-----
+## Documentation
+
+- [reflex](https://hackage.haskell.org/package/reflex-0.6.2.1/docs/doc-index-All.html)
+- [reflex-dom](https://hackage.haskell.org/package/reflex-dom-0.3/docs/doc-index-All.html)
+
+## TODO
### Interface
diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs
index 67f97c0..d679f9b 100644
--- a/client/src/Component/Input.hs
+++ b/client/src/Component/Input.hs
@@ -53,7 +53,7 @@ input
input inputIn reset validate = do
rec
let resetValue = R.leftmost
- [ R.traceEvent "reset" reset
+ [ reset
, fmap (const "") resetClic
]
@@ -83,7 +83,7 @@ input inputIn reset validate = do
[ const (False, True) <$> resetClic
, (\f -> (f, False)) <$> (R.updated . R._textInput_hasFocus $ textInput)
, const (False, False) <$> validate
- , const (True, False) <$> R.traceEvent "delayedReset" delayedReset
+ , const (True, False) <$> delayedReset
])
(textInput, resetClic) <- R.elDynAttr "div" containerAttr $ do
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index 007471d..f614936 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -10,7 +10,8 @@ import Prelude hiding (init)
import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex)
import qualified Reflex.Dom as R
-import Common.Model (Frequency, Init (..), Payment (..),
+import Common.Model (CreatedPayment (..), Frequency, Init (..),
+ Payment (..), PaymentCategory (..),
PaymentId)
import qualified Common.Util.Text as T
import View.Payment.Header (HeaderIn (..), HeaderOut (..))
@@ -37,8 +38,12 @@ widget paymentIn = do
payments <- getPayments
(_init_payments init)
- (_headerOut_addedPayment header)
- (_tableOut_deletedPayment table)
+ (_createdPayment_payment <$> _headerOut_addPayment header)
+ (_tableOut_deletePayment table)
+
+ paymentCategories <- getPaymentCategories
+ (_init_paymentCategories init)
+ (_createdPayment_paymentCategory <$> _headerOut_addPayment header)
let searchPayments =
getSearchPayments
@@ -56,6 +61,7 @@ widget paymentIn = do
, _tableIn_currentPage = _pagesOut_currentPage pages
, _tableIn_payments = searchPayments
, _tableIn_perPage = paymentsPerPage
+ , _tableIn_paymentCategories = paymentCategories
}
pages <- Pages.widget $ PagesIn
@@ -63,7 +69,7 @@ widget paymentIn = do
, _pagesIn_perPage = paymentsPerPage
, _pagesIn_reset = R.leftmost $
[ fmap (const ()) . R.updated . _headerOut_searchName $ header
- , fmap (const ()) . _headerOut_addedPayment $ header
+ , fmap (const ()) . _headerOut_addPayment $ header
]
}
@@ -75,10 +81,20 @@ getPayments
-> Event t Payment
-> Event t PaymentId
-> m (Dynamic t [Payment])
-getPayments initPayments addedPayment deletedPayment =
+getPayments initPayments addPayment deletePayment =
R.foldDyn id initPayments $ R.leftmost
- [ flip fmap addedPayment (:)
- , flip fmap deletedPayment (\paymentId -> filter ((/= paymentId) . _payment_id))
+ [ (:) <$> addPayment
+ , flip fmap deletePayment (\paymentId -> filter ((/= paymentId) . _payment_id))
+ ]
+
+getPaymentCategories
+ :: forall t m. MonadWidget t m
+ => [PaymentCategory]
+ -> Event t PaymentCategory
+ -> m (Dynamic t [PaymentCategory])
+getPaymentCategories initPaymentCategories addPaymentCategory =
+ R.foldDyn id initPaymentCategories $ R.leftmost
+ [ (:) <$> addPaymentCategory
]
getSearchPayments
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index 62b26a3..2970394 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -16,7 +16,8 @@ import qualified Reflex.Dom as R
import qualified Text.Read as T
import Common.Model (Category (..), CreatePayment (..),
- Frequency (..), Payment (..))
+ CreatedPayment (..), Frequency (..),
+ Payment (..), PaymentCategory (..))
import qualified Common.Msg as Msg
import qualified Common.Util.Time as Time
import qualified Common.Validation.Payment as PaymentValidation
@@ -35,8 +36,9 @@ data AddIn t = AddIn
}
data AddOut t = AddOut
- { _addOut_cancel :: Event t ()
- , _addOut_addedPayment :: Event t Payment
+ { _addOut_cancel :: Event t ()
+ , _addOut_addPayment :: Event t CreatedPayment
+ , _addOut_addPaymentCategory :: Event t PaymentCategory
}
view :: forall t m. MonadWidget t m => AddIn t -> m (AddOut t)
@@ -48,7 +50,7 @@ view addIn = do
rec
let reset = R.leftmost
[ const "" <$> cancel
- , const "" <$> addedPayment
+ , const "" <$> addPayment
, const "" <$> _addIn_cancel addIn
]
@@ -68,8 +70,10 @@ view addIn = do
reset
validate)
+ now <- liftIO Time.getCurrentTime
+
currentDay <- do
- d <- liftIO $ Time.getCurrentTime >>= Time.timeToDay
+ d <- liftIO $ Time.timeToDay now
return . T.pack . Calendar.showGregorian $ d
date <- _inputOut_value <$> (Component.input
@@ -118,7 +122,7 @@ view addIn = do
<*> ValidationUtil.nelError (V.Success cat)
<*> ValidationUtil.nelError (V.Success f)
- (addedPayment, cancel, validate) <- R.divClass "buttons" $ do
+ (addPayment, cancel, validate) <- R.divClass "buttons" $ do
rec
cancel <- Component._buttonOut_clic <$> (Component.button $
(Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
@@ -131,15 +135,15 @@ view addIn = do
, _buttonIn_submit = True
})
- (result, waiting) <- WaitFor.waitFor
+ (addPayment, waiting) <- WaitFor.waitFor
(Ajax.postJson "/payment")
(ValidationUtil.fireValidation payment validate)
- return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel, validate)
+ return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, validate)
return AddOut
{ _addOut_cancel = cancel
- , _addOut_addedPayment = addedPayment
+ , _addOut_addPayment = addPayment
}
where
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index 56441eb..c49b284 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -17,10 +17,10 @@ import Prelude hiding (init)
import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex)
import qualified Reflex.Dom as R
-import Common.Model (Category, Currency,
- ExceedingPayer (..), Frequency (..),
- Income (..), Init (..), Payment (..),
- User (..))
+import Common.Model (Category, CreatedPayment (..),
+ Currency, ExceedingPayer (..),
+ Frequency (..), Income (..), Init (..),
+ Payment (..), User (..))
import qualified Common.Model as CM
import qualified Common.Msg as Msg
import qualified Common.View.Format as Format
@@ -41,14 +41,14 @@ data HeaderIn t = HeaderIn
data HeaderOut t = HeaderOut
{ _headerOut_searchName :: Dynamic t Text
, _headerOut_searchFrequency :: Dynamic t Frequency
- , _headerOut_addedPayment :: Event t Payment
+ , _headerOut_addPayment :: Event t CreatedPayment
}
widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t)
widget headerIn =
R.divClass "header" $ do
- addedPayment <- payerAndAdd incomes punctualPayments users categories currency
- let resetSearchName = fmap (const ()) $ addedPayment
+ addPayment <- payerAndAdd incomes punctualPayments users categories currency
+ let resetSearchName = fmap (const ()) $ addPayment
(searchName, searchFrequency) <- searchLine resetSearchName
infos (_headerIn_searchPayments headerIn) users currency
@@ -56,7 +56,7 @@ widget headerIn =
return $ HeaderOut
{ _headerOut_searchName = searchName
, _headerOut_searchFrequency = searchFrequency
- , _headerOut_addedPayment = addedPayment
+ , _headerOut_addPayment = addPayment
}
where
init = _headerIn_init headerIn
@@ -74,7 +74,7 @@ payerAndAdd
-> [User]
-> [Category]
-> Currency
- -> m (Event t Payment)
+ -> m (Event t CreatedPayment)
payerAndAdd incomes payments users categories currency = do
time <- liftIO Time.getCurrentTime
R.divClass "payerAndAdd" $ do
@@ -101,7 +101,7 @@ payerAndAdd incomes payments users categories currency = do
{ _modalIn_show = addPaymentClic
, _modalIn_hide = R.leftmost $
[ _addOut_cancel addOut
- , fmap (const ()) . _addOut_addedPayment $ addOut
+ , fmap (const ()) . _addOut_addPayment $ addOut
]
, _modalIn_content = Add.view $ AddIn
{ _addIn_categories = categories
@@ -109,7 +109,7 @@ payerAndAdd incomes payments users categories currency = do
}
}
let addOut = _modalOut_content modalOut
- return (_addOut_addedPayment addOut)
+ return (_addOut_addPayment addOut)
searchLine
:: forall t m. MonadWidget t m
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index ba16bf5..6432274 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -29,21 +29,22 @@ import qualified Icon
import qualified Util.Dom as Dom
data TableIn t = TableIn
- { _tableIn_init :: Init
- , _tableIn_currentPage :: Dynamic t Int
- , _tableIn_payments :: Dynamic t [Payment]
- , _tableIn_perPage :: Int
+ { _tableIn_init :: Init
+ , _tableIn_currentPage :: Dynamic t Int
+ , _tableIn_payments :: Dynamic t [Payment]
+ , _tableIn_perPage :: Int
+ , _tableIn_paymentCategories :: Dynamic t [PaymentCategory]
}
data TableOut t = TableOut
- { _tableOut_deletedPayment :: Event t PaymentId
+ { _tableOut_deletePayment :: Event t PaymentId
}
widget :: forall t m. MonadWidget t m => TableIn t -> m (TableOut t)
widget tableIn = do
R.divClass "table" $ do
- deletedPayment <- R.divClass "lines" $ do
+ deletePayment <- R.divClass "lines" $ do
R.divClass "header" $ do
R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name
R.divClass "cell cost" $ R.text $ Msg.get Msg.Payment_Cost
@@ -53,13 +54,14 @@ widget tableIn = do
R.divClass "cell" $ R.blank
R.divClass "cell" $ R.blank
R.divClass "cell" $ R.blank
- (R.switch . R.current . fmap R.leftmost) <$> (R.simpleList paymentRange (paymentRow init))
+ (R.switch . R.current . fmap R.leftmost) <$>
+ (R.simpleList paymentRange (paymentRow init paymentCategories))
Dom.divClassVisibleIf (null <$> payments) "emptyTableMsg" $
R.text $ Msg.get Msg.Payment_Empty
return $ TableOut
- { _tableOut_deletedPayment = deletedPayment
+ { _tableOut_deletePayment = deletePayment
}
where
@@ -67,6 +69,7 @@ widget tableIn = do
currentPage = _tableIn_currentPage tableIn
payments = _tableIn_payments tableIn
paymentRange = getPaymentRange (_tableIn_perPage tableIn) <$> payments <*> currentPage
+ paymentCategories = _tableIn_paymentCategories tableIn
getPaymentRange :: Int -> [Payment] -> Int -> [Payment]
getPaymentRange perPage payments currentPage =
@@ -76,8 +79,8 @@ getPaymentRange perPage payments currentPage =
. L.sortOn _payment_date
$ payments
-paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m (Event t PaymentId)
-paymentRow init payment =
+paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t [PaymentCategory] -> Dynamic t Payment -> m (Event t PaymentId)
+paymentRow init 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
@@ -88,10 +91,10 @@ paymentRow init payment =
Just u -> _user_name u
_ -> ""
- let category = flip fmap payment $ \p -> findCategory
- (_init_categories init)
- (_init_paymentCategories init)
- (_payment_name p)
+ let category = do
+ p <- payment
+ pcs <- paymentCategories
+ return $ findCategory (_init_categories init) pcs (_payment_name p)
R.divClass "cell category" $ do
let attrs = flip fmap category $ \maybeCategory -> case maybeCategory of
Just c -> M.fromList
diff --git a/common/common.cabal b/common/common.cabal
index 9881c64..b7e0416 100644
--- a/common/common.cabal
+++ b/common/common.cabal
@@ -29,6 +29,7 @@ Library
Exposed-modules:
Common.Model
Common.Model.CreatePayment
+ Common.Model.CreatedPayment
Common.Model.Email
Common.Model.Payment
Common.Model.SignInForm
diff --git a/common/src/Common/Model.hs b/common/src/Common/Model.hs
index b0e0491..64db890 100644
--- a/common/src/Common/Model.hs
+++ b/common/src/Common/Model.hs
@@ -2,6 +2,7 @@ module Common.Model (module X) where
import Common.Model.Category as X
import Common.Model.CreateCategory as X
+import Common.Model.CreatedPayment as X
import Common.Model.CreateIncome as X
import Common.Model.CreatePayment as X
import Common.Model.Currency as X
diff --git a/common/src/Common/Model/CreatedPayment.hs b/common/src/Common/Model/CreatedPayment.hs
new file mode 100644
index 0000000..c1bba29
--- /dev/null
+++ b/common/src/Common/Model/CreatedPayment.hs
@@ -0,0 +1,17 @@
+module Common.Model.CreatedPayment
+ ( CreatedPayment(..)
+ ) where
+
+import Data.Aeson (FromJSON, ToJSON)
+import GHC.Generics (Generic)
+
+import Common.Model.Payment (Payment)
+import Common.Model.PaymentCategory (PaymentCategory)
+
+data CreatedPayment = CreatedPayment
+ { _createdPayment_payment :: Payment
+ , _createdPayment_paymentCategory :: PaymentCategory
+ } deriving (Show, Generic)
+
+instance FromJSON CreatedPayment
+instance ToJSON CreatedPayment
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index fb7fcb2..e82fd49 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -10,6 +10,7 @@ import qualified Network.HTTP.Types.Status as Status
import Web.Scotty
import Common.Model (CreatePayment (..),
+ CreatedPayment (..),
EditPayment (..), PaymentId,
User (..))
import qualified Model.Query as Query
@@ -30,8 +31,9 @@ create createPayment@(CreatePayment name cost date category frequency) =
case CreatePaymentValidation.validate createPayment of
Nothing ->
(liftIO . Query.run $ do
- PaymentCategoryPersistence.save name category
- PaymentPersistence.create (_user_id user) name cost date frequency
+ pc <- PaymentCategoryPersistence.save name category
+ p <- PaymentPersistence.create (_user_id user) name cost date frequency
+ return $ CreatedPayment p pc
) >>= json
Just validationError ->
do
diff --git a/server/src/Persistence/PaymentCategory.hs b/server/src/Persistence/PaymentCategory.hs
index 1e377b1..1cfd702 100644
--- a/server/src/Persistence/PaymentCategory.hs
+++ b/server/src/Persistence/PaymentCategory.hs
@@ -4,7 +4,7 @@ module Persistence.PaymentCategory
, save
) where
-import Data.Maybe (isJust, listToMaybe)
+import qualified Data.Maybe as Maybe
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (getCurrentTime)
@@ -40,27 +40,41 @@ listByCategory cat =
SQLite.query conn "SELECT * FROM payment_category WHERE category = ?" (Only cat)
)
-save :: Text -> CategoryId -> Query ()
+save :: Text -> CategoryId -> Query PaymentCategory
save newName categoryId =
Query (\conn -> do
now <- getCurrentTime
- hasPaymentCategory <- isJust <$> listToMaybe <$>
+ paymentCategory <- fmap (\(Row pc) -> pc) . Maybe.listToMaybe <$>
(SQLite.query
conn
"SELECT * FROM payment_category WHERE name = ?"
- (Only (formatPaymentName newName)) :: IO [Row])
- if hasPaymentCategory
- then
- SQLite.execute
- conn
- "UPDATE payment_category SET category = ?, edited_at = ? WHERE name = ?"
- (categoryId, now, formatPaymentName newName)
- else do
- SQLite.execute
- conn
- "INSERT INTO payment_category (name, category, created_at) VALUES (?, ?, ?)"
- (formatPaymentName newName, categoryId, now)
+ (Only formattedNewName))
+ case paymentCategory of
+ Just pc ->
+ do
+ SQLite.execute
+ conn
+ "UPDATE payment_category SET category = ?, edited_at = ? WHERE name = ?"
+ (categoryId, now, formattedNewName)
+ return $ PaymentCategory
+ (_paymentCategory_id pc)
+ formattedNewName
+ categoryId
+ (_paymentCategory_createdAt pc)
+ (Just now)
+ Nothing ->
+ do
+ SQLite.execute
+ conn
+ "INSERT INTO payment_category (name, category, created_at) VALUES (?, ?, ?)"
+ (formattedNewName, categoryId, now)
+ paymentCategoryId <- SQLite.lastInsertRowId conn
+ return $ PaymentCategory
+ paymentCategoryId
+ formattedNewName
+ categoryId
+ now
+ Nothing
)
where
- formatPaymentName :: Text -> Text
- formatPaymentName = T.unaccent . T.toLower
+ formattedNewName = T.unaccent . T.toLower $ newName
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 19:46:59 +0000