aboutsummaryrefslogtreecommitdiff
path: root/src/server
diff options
context:
space:
mode:
Diffstat (limited to 'src/server')
-rw-r--r--src/server/Controller/Payment.hs12
-rw-r--r--src/server/Design/Dialog.hs13
-rw-r--r--src/server/Design/Form.hs24
-rw-r--r--src/server/Design/Global.hs2
-rw-r--r--src/server/Design/Helper.hs18
-rw-r--r--src/server/Design/LoggedIn.hs12
-rw-r--r--src/server/Design/LoggedIn/Home.hs8
-rw-r--r--src/server/Design/LoggedIn/Home/Add.hs87
-rw-r--r--src/server/Design/LoggedIn/Home/Header.hs56
-rw-r--r--src/server/Design/LoggedIn/Home/Monthly.hs23
-rw-r--r--src/server/Design/LoggedIn/Home/Search.hs31
-rw-r--r--src/server/Design/LoggedIn/Home/Table.hs123
-rw-r--r--src/server/Main.hs2
-rw-r--r--src/server/Model/Message/Key.hs28
-rw-r--r--src/server/Model/Message/Translations.hs93
-rw-r--r--src/server/Model/Payment.hs28
-rw-r--r--src/server/Validation.hs18
17 files changed, 245 insertions, 333 deletions
diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs
index 7e8d0a3..294e4c4 100644
--- a/src/server/Controller/Payment.hs
+++ b/src/server/Controller/Payment.hs
@@ -15,7 +15,6 @@ import Database.Persist
import Control.Monad.IO.Class (liftIO)
import Data.Text (Text)
-import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Aeson.Types as Json
@@ -34,16 +33,11 @@ getPayments =
(liftIO $ runDb P.getPayments) >>= json
)
-createPayment :: Text -> Text -> Frequency -> ActionM ()
+createPayment :: Text -> Int -> Frequency -> ActionM ()
createPayment name cost frequency =
Secure.loggedAction (\user -> do
- creationResult <- liftIO . runDb $ P.createPayment (entityKey user) name cost frequency
- case creationResult of
- Left errors -> do
- status badRequest400
- jsonObject . map (\(a, b) -> (a, Json.String . T.pack . show $ b)) $ errors
- Right paymentId ->
- jsonObject [("id", Json.Number . fromIntegral . keyToInt64 $ paymentId)]
+ paymentId <- liftIO . runDb $ P.createPayment (entityKey user) name cost frequency
+ jsonObject [("id", Json.Number . fromIntegral . keyToInt64 $ paymentId)]
)
deleteOwnPayment :: Text -> ActionM ()
diff --git a/src/server/Design/Dialog.hs b/src/server/Design/Dialog.hs
new file mode 100644
index 0000000..f0b8009
--- /dev/null
+++ b/src/server/Design/Dialog.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Design.Dialog
+ ( design
+ ) where
+
+import Clay
+
+design :: Css
+design = do
+
+ ".paymentDialog" ? do
+ ".radioGroup" ? ".title" ? display none
diff --git a/src/server/Design/Form.hs b/src/server/Design/Form.hs
index 4bd1ad6..c2537f1 100644
--- a/src/server/Design/Form.hs
+++ b/src/server/Design/Form.hs
@@ -66,14 +66,18 @@ design = do
color Color.silver
marginBottom (em 0.8)
- ".radioElems" ? do
+ ".radioInputs" ? do
display flex
- "justify-content" -: "space-around"
-
- label ? do
- marginBottom (px 5)
- display block
- cursor pointer
- input ? do
- margin (px 0) (px 8) (px (-1)) (px 0)
- cursor pointer
+ "justify-content" -: "center"
+
+ ".radioInput:not(:last-child)::after" ? do
+ content (stringContent "/")
+ marginLeft (px 10)
+ marginRight (px 10)
+
+ input ? display none
+ label ? cursor pointer
+
+ "input:checked + label" ? do
+ color Color.chestnutRose
+ fontWeight bold
diff --git a/src/server/Design/Global.hs b/src/server/Design/Global.hs
index 7d4a1bb..149769c 100644
--- a/src/server/Design/Global.hs
+++ b/src/server/Design/Global.hs
@@ -12,6 +12,7 @@ import qualified Design.Header as Header
import qualified Design.SignIn as SignIn
import qualified Design.LoggedIn as LoggedIn
import qualified Design.Form as Form
+import qualified Design.Dialog as Dialog
import Design.Animation.Keyframes
@@ -28,6 +29,7 @@ global = do
header ? Header.design
".signIn" ? SignIn.design
".loggedIn" ? LoggedIn.design
+ ".dialog" ? Dialog.design
Form.design
allKeyframes
diff --git a/src/server/Design/Helper.hs b/src/server/Design/Helper.hs
index deb0aab..c8b3070 100644
--- a/src/server/Design/Helper.hs
+++ b/src/server/Design/Helper.hs
@@ -3,10 +3,9 @@
module Design.Helper
( clearFix
, defaultButton
- , iconButton
, defaultInput
+ , iconButton
, centeredWithMargin
- , expandBlock
, verticalCentering
) where
@@ -69,21 +68,6 @@ centeredWithMargin = do
marginLeft auto
marginRight auto
-expandBlock :: Color -> Color -> Size Abs -> Css
-expandBlock headerBackground headerColor headerHeight = do
- marginBottom blockMarginBottom
- marginLeft (pct blockPercentMargin)
- marginRight (pct blockPercentMargin)
- ".header" ? do
- defaultButton headerBackground headerColor headerHeight focusLighten
- width (pct 100)
- fontSize (px 18)
- borderRadius radius radius radius radius
- textAlign (alignSide sideLeft)
- position relative
- paddingLeft blockPadding
- paddingRight (px 55)
-
verticalCentering :: Css
verticalCentering = do
position absolute
diff --git a/src/server/Design/LoggedIn.hs b/src/server/Design/LoggedIn.hs
index 63ff413..5a3297a 100644
--- a/src/server/Design/LoggedIn.hs
+++ b/src/server/Design/LoggedIn.hs
@@ -8,15 +8,15 @@ import Data.Monoid ((<>))
import Clay
-import qualified Design.LoggedIn.Home as HomeDesign
-import qualified Design.LoggedIn.Income as IncomeDesign
-import qualified Design.LoggedIn.Stat as StatDesign
+import qualified Design.LoggedIn.Home as Home
+import qualified Design.LoggedIn.Income as Income
+import qualified Design.LoggedIn.Stat as Stat
design :: Css
design = do
- ".home" ? HomeDesign.design
- ".income" ? IncomeDesign.design
- ".stat" ? StatDesign.design
+ ".home" ? Home.design
+ ".income" ? Income.design
+ ".stat" ? Stat.design
(".income" <> ".stat") ? do
"margin" -: "0 2vw"
diff --git a/src/server/Design/LoggedIn/Home.hs b/src/server/Design/LoggedIn/Home.hs
index 47bfc84..7845434 100644
--- a/src/server/Design/LoggedIn/Home.hs
+++ b/src/server/Design/LoggedIn/Home.hs
@@ -6,16 +6,12 @@ module Design.LoggedIn.Home
import Clay
-import qualified Design.LoggedIn.Home.Add as Add
-import qualified Design.LoggedIn.Home.Monthly as Monthly
-import qualified Design.LoggedIn.Home.Search as Search
+import qualified Design.LoggedIn.Home.Header as Header
import qualified Design.LoggedIn.Home.Table as Table
import qualified Design.LoggedIn.Home.Pages as Pages
design :: Css
design = do
- form # ".addPayment" ? Add.design
- ".monthly" ? Monthly.design
- ".search" ? Search.design
+ ".header" ? Header.design
".table" ? Table.design
".pages" ? Pages.design
diff --git a/src/server/Design/LoggedIn/Home/Add.hs b/src/server/Design/LoggedIn/Home/Add.hs
deleted file mode 100644
index ce64077..0000000
--- a/src/server/Design/LoggedIn/Home/Add.hs
+++ /dev/null
@@ -1,87 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Design.LoggedIn.Home.Add
- ( design
- ) where
-
-import Data.Monoid ((<>))
-
-import Clay
-
-import Design.Color as Color
-import Design.Helper
-import Design.Constants
-
-design :: Css
-design = do
- centeredWithMargin
- display flex
- "justify-content" -: "center"
-
- ".name" <> ".cost" ? do
- position relative
- display flex
- marginRight (pct blockPercentMargin)
- label ? do
- fontWeight bold
- display inlineBlock
- width (px 50)
- textAlign (alignSide sideCenter)
- backgroundColor Color.dustyGray
- color Color.white
- height (px inputHeight)
- lineHeight (px inputHeight)
- fontSize (px 22)
- verticalAlign middle
- cursor cursorText
- borderRadius (px 0) radius radius (px 0)
- input ? do
- defaultInput inputHeight
- borderRadius radius (px 0) (px 0) radius
- "width" -: "calc(100% - 40px)"
- input # focus |+ label ?
- backgroundColor Color.silver
- hover & do
- input ? borderColor Color.silver
- label ? backgroundColor Color.silver
-
- ".name" ? minWidth (px 150)
-
- button # ".frequency" ? do
- fontSize (pct 90)
- marginRight (pct blockPercentMargin)
-
- (".punctual" <> ".monthly") ? do
- defaultButton Color.wildSand Color.dustyGray (px $ inputHeight `Prelude.div` 2) focusLighten
- paddingLeft (px 15)
- paddingRight (px 15)
- ".selected" & do
- backgroundColor Color.gothic
- color Color.white
-
- hover & (".punctual" <> ".monthly") ?
- ".selected" & backgroundColor (focusLighten Color.gothic)
-
- focus & (".punctual" <> ".monthly") ?
- ".selected" & backgroundColor (focusLighten Color.gothic)
-
- ".punctual" ? borderRadius radius radius 0 0
- ".monthly" ? borderRadius 0 0 radius radius
-
- button # ".add" ? do
- defaultButton Color.chestnutRose Color.white (px inputHeight) focusLighten
- paddingLeft (px 15)
- paddingRight (px 15)
- i ? marginLeft (px 10)
- ".waitingServer" & ("cursor" -: "not-allowed")
-
- ".name.error" <> ".cost.error" ? do
- input ? borderColor Color.chestnutRose
- label ? backgroundColor Color.chestnutRose
- "input:focus + label" ? backgroundColor Color.chestnutRose
-
- ".errorMessage" ? do
- position absolute
- color Color.chestnutRose
- top (px (inputHeight + 10))
- left (px 0)
diff --git a/src/server/Design/LoggedIn/Home/Header.hs b/src/server/Design/LoggedIn/Home/Header.hs
new file mode 100644
index 0000000..9008a95
--- /dev/null
+++ b/src/server/Design/LoggedIn/Home/Header.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Design.LoggedIn.Home.Header
+ ( design
+ ) where
+
+import Clay
+
+import Design.Constants
+
+import qualified Design.Helper as Helper
+import qualified Design.Color as Color
+import qualified Design.Constants as Constants
+
+design :: Css
+design = do
+ marginBottom blockMarginBottom
+ marginLeft (pct blockPercentMargin)
+ marginRight (pct blockPercentMargin)
+
+ ".exceedingPayers" ? do
+ backgroundColor Color.mossGreen
+ padding (px 10) (px 10) (px 10) (px 10)
+ borderRadius (px 5) (px 5) (px 5) (px 5)
+ color Color.white
+ marginBottom (em 1)
+
+ ".exceedingPayer:not(:last-child)::after" ? content (stringContent ", ")
+
+ ".userName" ? marginRight (px 5)
+
+ ".searchLine" ? do
+ marginBottom (em 1)
+ form ? do
+ display inlineBlock
+
+ ".textInput" ? do
+ display inlineBlock
+ marginRight (px 30)
+ marginBottom (px 0)
+
+ ".radioGroup" ? do
+ display inlineBlock
+ marginBottom (px 0)
+ ".title" ? display none
+
+ ".addPayment" ? do
+ Helper.defaultButton Color.chestnutRose Color.white (px 47) Constants.focusLighten
+ float floatRight
+
+ ".infos" ? do
+ lineHeight (px Constants.inputHeight)
+
+ ".partition" ? do
+ color Color.dustyGray
+ marginLeft (px 15)
diff --git a/src/server/Design/LoggedIn/Home/Monthly.hs b/src/server/Design/LoggedIn/Home/Monthly.hs
deleted file mode 100644
index 5e976ef..0000000
--- a/src/server/Design/LoggedIn/Home/Monthly.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Design.LoggedIn.Home.Monthly
- ( design
- ) where
-
-import Clay
-
-import Design.Color as Color
-import Design.Helper
-import Design.Constants
-
-design :: Css
-design = do
-
- expandBlock Color.gothic Color.white (px inputHeight)
-
- ".expand" ? do
- position absolute
- right blockPadding
- bottom (px 0)
-
- ".detail" |> ".header" ? borderRadius radius radius 0 0
diff --git a/src/server/Design/LoggedIn/Home/Search.hs b/src/server/Design/LoggedIn/Home/Search.hs
deleted file mode 100644
index 726b4cf..0000000
--- a/src/server/Design/LoggedIn/Home/Search.hs
+++ /dev/null
@@ -1,31 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Design.LoggedIn.Home.Search
- ( design
- ) where
-
-import Clay
-
-import Design.Constants
-
-import qualified Design.Helper as Helper
-import qualified Design.Color as Color
-import qualified Design.Constants as Constants
-
-design :: Css
-design = do
- marginBottom blockMarginBottom
- marginLeft (pct blockPercentMargin)
- marginRight (pct blockPercentMargin)
-
- ".textInput" ? do
- display inlineBlock
- marginRight (px 30)
- marginBottom (px 0)
-
- ".stat" ? do
- lineHeight (pct 100)
-
- ".addPayment" ? do
- Helper.defaultButton Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten
- float floatRight
diff --git a/src/server/Design/LoggedIn/Home/Table.hs b/src/server/Design/LoggedIn/Home/Table.hs
index 538bc6d..a229132 100644
--- a/src/server/Design/LoggedIn/Home/Table.hs
+++ b/src/server/Design/LoggedIn/Home/Table.hs
@@ -16,70 +16,75 @@ import Design.Helper
design :: Css
design = do
- display D.table
- width (pct 100)
- textAlign (alignSide (sideCenter))
+ ".noPayment" ? do
+ margin (em 2) (em 2) (em 2) (em 2)
+ textAlign (alignSide sideCenter)
- ".header" <> ".row" ? display tableRow
- let headerHeight = (px 70)
+ ".lines" ? do
+ display D.table
+ width (pct 100)
+ textAlign (alignSide (sideCenter))
- ".header" ? do
- fontWeight bold
- backgroundColor Color.gothic
- color Color.white
- fontSize iconFontSize
- height headerHeight
+ ".header" <> ".row" ? display tableRow
+ let headerHeight = (px 70)
- ".row" ? do
- fontSize (px 18)
- height (px rowHeightPx)
- ".cell:first-child::before" ? do
- display block
- content (stringContent "")
- position absolute
- top (px 0)
- left (px 0)
- width (px 0)
+ ".header" ? do
+ fontWeight bold
+ backgroundColor Color.gothic
+ color Color.white
+ fontSize (px 18)
+ height headerHeight
+
+ ".row" ? do
+ fontSize (px 18)
height (px rowHeightPx)
- backgroundColor Color.mossGreen
- transition "width" (sec 0.3) ease (sec 0)
- opacity (0.8)
+ ".cell:first-child::before" ? do
+ display block
+ content (stringContent "")
+ position absolute
+ top (px 0)
+ left (px 0)
+ width (px 0)
+ height (px rowHeightPx)
+ backgroundColor Color.mossGreen
+ transition "width" (sec 0.3) ease (sec 0)
+ opacity (0.8)
- hover & do
- ".cell:first-child::before" ? width (px 5)
+ hover & do
+ ".cell:first-child::before" ? width (px 5)
- nthChild "odd" & do
- backgroundColor Color.wildSand
- ".edition" & do
- backgroundColor Color.negroni
- ".delete" |> button ? visibility visible
+ nthChild "odd" & do
+ backgroundColor Color.wildSand
+ ".edition" & do
+ backgroundColor Color.negroni
+ ".delete" |> button ? visibility visible
- ".cell" ? do
- display tableCell
- position relative
- verticalAlign middle
- ".category" & width (pct 40)
- ".cost" & do
- width (pct 17)
- ".refund" & color Color.mossGreen
- ".user" & width (pct 20)
- ".date" & do
- width (pct 20)
- Media.mobileTablet $ do
- ".shortDate" ? display inline
- ".longDate" ? display none
- Media.desktop $ do
- ".shortDate" ? display none
- ".longDate" ? display inline
- ".delete" & do
+ ".cell" ? do
+ display tableCell
position relative
- width (pct 3)
- textAlign (alignSide sideCenter)
- button ? do
- defaultButton Color.chestnutRose Color.white (px rowHeightPx) focusLighten
- borderRadius (px 0) (px 0) (px 0) (px 0)
- position absolute
- top (px 0)
- right (px 0)
- width (pct 100)
- visibility hidden
+ verticalAlign middle
+ ".category" & width (pct 40)
+ ".cost" & do
+ width (pct 17)
+ ".refund" & color Color.mossGreen
+ ".user" & width (pct 20)
+ ".date" & do
+ width (pct 20)
+ Media.mobileTablet $ do
+ ".shortDate" ? display inline
+ ".longDate" ? display none
+ Media.desktop $ do
+ ".shortDate" ? display none
+ ".longDate" ? display inline
+ ".delete" & do
+ position relative
+ width (pct 3)
+ textAlign (alignSide sideCenter)
+ button ? do
+ defaultButton Color.chestnutRose Color.white (px rowHeightPx) focusLighten
+ borderRadius (px 0) (px 0) (px 0) (px 0)
+ position absolute
+ top (px 0)
+ right (px 0)
+ width (pct 100)
+ visibility hidden
diff --git a/src/server/Main.hs b/src/server/Main.hs
index 9946961..d04a3ac 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -74,7 +74,7 @@ main = do
post "/payment/add" $ do
name <- param "name" :: ActionM Text
- cost <- param "cost" :: ActionM Text
+ cost <- param "cost" :: ActionM Int
frequency <- param "frequency" :: ActionM Frequency
createPayment name cost frequency
diff --git a/src/server/Model/Message/Key.hs b/src/server/Model/Message/Key.hs
index c87a2c1..8b957f1 100644
--- a/src/server/Model/Message/Key.hs
+++ b/src/server/Model/Message/Key.hs
@@ -47,15 +47,19 @@ data Key =
| ShortDate
| LongDate
- -- Validation
+ -- Search
- | CategoryRequired
- | CostRequired
+ | SearchName
+ | SearchPunctual
+ | SearchMonthly
-- Payments
+ | PaymentsAreBalanced
| Name
| Cost
+ | Payer
+ | Date
| Frequency
| InvalidFrequency
| AddPayment
@@ -63,22 +67,22 @@ data Key =
| Punctual
| Monthly
- | SingularMonthlyCount
- | PluralMonthlyCount
| PaymentsTitle
| Payment
| Payments
- | SearchText
| Worth
+ | NoPayment
+
+ | PaymentName
+ | PaymentCost
+ | PaymentPunctual
+ | PaymentMonthly
-- Statistics
| Statistics
- | Balance
- | Overall
- | ByMonths
+ | ByMonthsAndMean
| By
- | Mean
-- Income
@@ -86,8 +90,8 @@ data Key =
| Income
| MonthlyNetIncomes
| IncomeNotDeleted
- | Creation
- | Amount
+ | IncomeCreation
+ | IncomeAmount
| ConfirmDelete
-- Form
diff --git a/src/server/Model/Message/Translations.hs b/src/server/Model/Message/Translations.hs
index f4087a4..df3f402 100644
--- a/src/server/Model/Message/Translations.hs
+++ b/src/server/Model/Message/Translations.hs
@@ -186,20 +186,30 @@ m l LongDate =
English -> "{2} {1}, {3}"
French -> "{1} {2} {3}"
--- Validation
+-- Search
-m l CategoryRequired =
+m l SearchName =
case l of
- English -> "Type a category."
- French -> "Entre une catégorie."
+ English -> "Search"
+ French -> "Recherche"
+
+m l SearchPunctual =
+ case l of
+ English -> "Punctual"
+ French -> "Ponctuel"
-m l CostRequired =
+m l SearchMonthly =
case l of
- English -> "Type a positive cost."
- French -> "Entre un coût positif."
+ English -> "Monthly"
+ French -> "Mensuel"
-- Payments
+m l PaymentsAreBalanced =
+ case l of
+ English -> "Payments are balanced."
+ French -> "Les paiements sont équilibrés."
+
m l Name =
case l of
English -> "Name"
@@ -210,6 +220,16 @@ m l Cost =
English -> "Cost"
French -> "Coût"
+m l Payer =
+ case l of
+ English -> "Payer"
+ French -> "Payeur"
+
+m l Date =
+ case l of
+ English -> "Date"
+ French -> "Date"
+
m l Frequency =
case l of
English -> "Frequency"
@@ -240,16 +260,6 @@ m l Monthly =
English -> "Monthly"
French -> "Mensuelle"
-m l SingularMonthlyCount =
- case l of
- English -> "{1} monthly payment of {2}"
- French -> "{1} paiement mensuel de {2}"
-
-m l PluralMonthlyCount =
- case l of
- English -> "{1} monthly payments worth {2}"
- French -> "{1} paiements mensuels comptabilisant {2}"
-
m l PaymentsTitle =
case l of
English -> "Payments"
@@ -265,16 +275,16 @@ m l Payments =
English -> "payments"
French -> "paiements"
-m l SearchText =
- case l of
- English -> "Search"
- French -> "Recherche"
-
m l Worth =
case l of
English -> "{1} worth {2}"
French -> "{1} comptabilisant {2}"
+m l NoPayment =
+ case l of
+ English -> "No payment found from your search criteria."
+ French -> "Aucun paiement ne correspond à vos critères de recherches."
+
-- Statistics
m l Statistics =
@@ -282,30 +292,35 @@ m l Statistics =
English -> "Statistics"
French -> "Statistiques"
-m l Balance =
+m l ByMonthsAndMean =
+ case l of
+ English -> "By months ({1} on average)"
+ French -> "Par mois (en moyenne {1})"
+
+m l By =
case l of
- English -> "Balance"
- French -> "Équilibre"
+ English -> "{1}: {2}"
+ French -> "{1} : {2}"
-m l Overall =
+m l PaymentName =
case l of
- English -> "Overall"
- French -> "Global"
+ English -> "Name"
+ French -> "Nom"
-m l ByMonths =
+m l PaymentCost =
case l of
- English -> "By months"
- French -> "Par mois"
+ English -> "Cost"
+ French -> "Coût"
-m l By =
+m l PaymentPunctual =
case l of
- English -> "by"
- French -> "par"
+ English -> "Punctual"
+ French -> "Ponctuel"
-m l Mean =
+m l PaymentMonthly =
case l of
- English -> "Mean: {1}"
- French -> "En moyenne : {1}"
+ English -> "Monthly"
+ French -> "Mensuel"
-- Income
@@ -329,12 +344,12 @@ m l IncomeNotDeleted =
English -> "The income could not have been deleted."
French -> "Le revenu n'a pas pu être supprimé."
-m l Creation =
+m l IncomeCreation =
case l of
English -> "Creation"
French -> "Création"
-m l Amount =
+m l IncomeAmount =
case l of
English -> "Amount"
French -> "Montant"
diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs
index 47397ff..28f1a09 100644
--- a/src/server/Model/Payment.hs
+++ b/src/server/Model/Payment.hs
@@ -9,18 +9,14 @@ module Model.Payment
import Data.Text (Text)
import Data.Time.Clock (getCurrentTime)
-import Data.Either (lefts)
import Control.Monad.IO.Class (liftIO)
import Database.Persist
-import qualified Validation
-
import Model.Database
import Model.Frequency
import qualified Model.Json.Payment as P
-import qualified Model.Message.Key as K
getPayments :: Persist [P.Payment]
getPayments =
@@ -48,26 +44,10 @@ getJsonPayment paymentEntity =
, P.frequency = paymentFrequency payment
}
-createPayment :: UserId -> Text -> Text -> Frequency -> Persist (Either [(Text, K.Key)] PaymentId)
-createPayment userId name cost frequency =
- case validatePayment name cost of
- Left err ->
- return . Left $ err
- Right (validatedName, validatedCost) -> do
- now <- liftIO getCurrentTime
- Right <$> insert (Payment userId now validatedName validatedCost Nothing frequency)
-
-validatePayment :: Text -> Text -> Either [(Text, K.Key)] (Text, Int)
-validatePayment name cost =
- let eitherName = Validation.nonEmpty K.CategoryRequired name
- eitherCost = Validation.nonEmpty K.CostRequired cost >>= Validation.number K.CostRequired (/= 0)
- in case (eitherName, eitherCost) of
- (Right validatedName, Right validatedCost) ->
- Right (validatedName, validatedCost)
- _ ->
- let nameErrors = map (\x -> ("name", x)) $ lefts [eitherName]
- costErrors = map (\x -> ("cost", x)) $ lefts [eitherCost]
- in Left (nameErrors ++ costErrors)
+createPayment :: UserId -> Text -> Int -> Frequency -> Persist PaymentId
+createPayment userId name cost frequency = do
+ now <- liftIO getCurrentTime
+ insert (Payment userId now name cost Nothing frequency)
deleteOwnPayment :: Entity User -> PaymentId -> Persist Bool
deleteOwnPayment user paymentId = do
diff --git a/src/server/Validation.hs b/src/server/Validation.hs
index 455ae5b..1f332c9 100644
--- a/src/server/Validation.hs
+++ b/src/server/Validation.hs
@@ -6,18 +6,18 @@ module Validation
import Data.Text (Text)
import qualified Data.Text as T
-nonEmpty :: a -> Text -> Either a Text
-nonEmpty x str =
+nonEmpty :: Text -> Maybe Text
+nonEmpty str =
if T.null str
- then Left x
- else Right str
+ then Nothing
+ else Just str
-number :: x -> (Int -> Bool) -> Text -> Either x Int
-number x numberForm str =
+number :: (Int -> Bool) -> Text -> Maybe Int
+number numberForm str =
case reads (T.unpack str) :: [(Int, String)] of
(num, _) : _ ->
if numberForm num
- then Right num
- else Left x
+ then Just num
+ else Nothing
_ ->
- Left x
+ Nothing
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-02 18:09:32 +0000