aboutsummaryrefslogtreecommitdiff
path: root/server
diff options
context:
space:
mode:
authorJoris2018-01-28 12:13:09 +0100
committerJoris2018-06-11 12:28:29 +0200
commit33b85b7f12798f5762d940ed5c30f775cdd7b751 (patch)
treedaf8cfb7b0a16b2fce65848fc0ca2831f33a0701 /server
parentab17b6339d16970c3845ec4f153bfeed89eae728 (diff)
WIP
Diffstat (limited to 'server')
-rw-r--r--server/server.cabal15
-rw-r--r--server/src/Controller/Category.hs30
-rw-r--r--server/src/Controller/Income.hs8
-rw-r--r--server/src/Controller/Index.hs18
-rw-r--r--server/src/Controller/Payment.hs40
-rw-r--r--server/src/Design/Form.hs12
-rw-r--r--server/src/Design/Modal.hs8
-rw-r--r--server/src/Design/View/Payment.hs2
-rw-r--r--server/src/Design/View/Payment/Add.hs32
-rw-r--r--server/src/Design/View/Payment/Header.hs9
-rw-r--r--server/src/Job/MonthlyPayment.hs16
-rw-r--r--server/src/Job/WeeklyReport.hs8
-rw-r--r--server/src/Model/IncomeResource.hs15
-rw-r--r--server/src/Model/Init.hs25
-rw-r--r--server/src/Model/PaymentResource.hs15
-rw-r--r--server/src/Model/User.hs48
-rw-r--r--server/src/Persistence/Category.hs (renamed from server/src/Model/Category.hs)23
-rw-r--r--server/src/Persistence/Frequency.hs (renamed from server/src/Model/Frequency.hs)21
-rw-r--r--server/src/Persistence/Income.hs (renamed from server/src/Model/Income.hs)30
-rw-r--r--server/src/Persistence/Init.hs25
-rw-r--r--server/src/Persistence/Payment.hs (renamed from server/src/Model/Payment.hs)84
-rw-r--r--server/src/Persistence/PaymentCategory.hs (renamed from server/src/Model/PaymentCategory.hs)29
-rw-r--r--server/src/Persistence/User.hs37
-rw-r--r--server/src/Secure.hs4
-rw-r--r--server/src/SendMail.hs1
-rw-r--r--server/src/Util/Time.hs17
-rw-r--r--server/src/View/Mail/WeeklyReport.hs55
27 files changed, 343 insertions, 284 deletions
diff --git a/server/server.cabal b/server/server.cabal
index ada7040..2bfd18d 100644
--- a/server/server.cabal
+++ b/server/server.cabal
@@ -72,6 +72,7 @@ Executable server
Design.Tooltip
Design.View.Header
Design.View.Payment
+ Design.View.Payment.Add
Design.View.Payment.Header
Design.View.Payment.Pages
Design.View.Payment.Table
@@ -87,17 +88,17 @@ Executable server
Job.WeeklyReport
Json
LoginSession
- Model.Category
- Model.Frequency
- Model.Income
- Model.Init
Model.Mail
- Model.Payment
- Model.PaymentCategory
Model.Query
Model.SignIn
Model.UUID
- Model.User
+ Persistence.Category
+ Persistence.Frequency
+ Persistence.Income
+ Persistence.Init
+ Persistence.Payment
+ Persistence.PaymentCategory
+ Persistence.User
Resource
Secure
SendMail
diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs
index 5565b43..37b8357 100644
--- a/server/src/Controller/Category.hs
+++ b/server/src/Controller/Category.hs
@@ -4,31 +4,31 @@ module Controller.Category
, delete
) where
-import Control.Monad.IO.Class (liftIO)
-import qualified Data.Text.Lazy as TL
-import Network.HTTP.Types.Status (badRequest400, ok200)
-import Web.Scotty hiding (delete)
+import Control.Monad.IO.Class (liftIO)
+import qualified Data.Text.Lazy as TL
+import Network.HTTP.Types.Status (badRequest400, ok200)
+import Web.Scotty hiding (delete)
-import Common.Model (CategoryId, CreateCategory (..),
- EditCategory (..))
-import qualified Common.Msg as Msg
+import Common.Model (CategoryId, CreateCategory (..),
+ EditCategory (..))
+import qualified Common.Msg as Msg
-import Json (jsonId)
-import qualified Model.Category as Category
-import qualified Model.PaymentCategory as PaymentCategory
-import qualified Model.Query as Query
+import Json (jsonId)
+import qualified Model.Query as Query
+import qualified Persistence.Category as CategoryPersistence
+import qualified Persistence.PaymentCategory as PaymentCategoryPersistence
import qualified Secure
create :: CreateCategory -> ActionM ()
create (CreateCategory name color) =
Secure.loggedAction (\_ ->
- (liftIO . Query.run $ Category.create name color) >>= jsonId
+ (liftIO . Query.run $ CategoryPersistence.create name color) >>= jsonId
)
edit :: EditCategory -> ActionM ()
edit (EditCategory categoryId name color) =
Secure.loggedAction (\_ -> do
- updated <- liftIO . Query.run $ Category.edit categoryId name color
+ updated <- liftIO . Query.run $ CategoryPersistence.edit categoryId name color
if updated
then status ok200
else status badRequest400
@@ -38,9 +38,9 @@ delete :: CategoryId -> ActionM ()
delete categoryId =
Secure.loggedAction (\_ -> do
deleted <- liftIO . Query.run $ do
- paymentCategories <- PaymentCategory.listByCategory categoryId
+ paymentCategories <- PaymentCategoryPersistence.listByCategory categoryId
if null paymentCategories
- then Category.delete categoryId
+ then CategoryPersistence.delete categoryId
else return False
if deleted
then
diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs
index 19f0cfc..3f623e5 100644
--- a/server/src/Controller/Income.hs
+++ b/server/src/Controller/Income.hs
@@ -14,20 +14,20 @@ import Common.Model (CreateIncome (..), EditIncome (..),
import qualified Common.Msg as Msg
import Json (jsonId)
-import qualified Model.Income as Income
import qualified Model.Query as Query
+import qualified Persistence.Income as IncomePersistence
import qualified Secure
create :: CreateIncome -> ActionM ()
create (CreateIncome date amount) =
Secure.loggedAction (\user ->
- (liftIO . Query.run $ Income.create (_user_id user) date amount) >>= jsonId
+ (liftIO . Query.run $ IncomePersistence.create (_user_id user) date amount) >>= jsonId
)
editOwn :: EditIncome -> ActionM ()
editOwn (EditIncome incomeId date amount) =
Secure.loggedAction (\user -> do
- updated <- liftIO . Query.run $ Income.editOwn (_user_id user) incomeId date amount
+ updated <- liftIO . Query.run $ IncomePersistence.editOwn (_user_id user) incomeId date amount
if updated
then status ok200
else status badRequest400
@@ -36,7 +36,7 @@ editOwn (EditIncome incomeId date amount) =
deleteOwn :: IncomeId -> ActionM ()
deleteOwn incomeId =
Secure.loggedAction (\user -> do
- deleted <- liftIO . Query.run $ Income.deleteOwn user incomeId
+ deleted <- liftIO . Query.run $ IncomePersistence.deleteOwn user incomeId
if deleted
then
status ok200
diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs
index 9a3e2b7..f942540 100644
--- a/server/src/Controller/Index.hs
+++ b/server/src/Controller/Index.hs
@@ -23,11 +23,11 @@ import qualified Common.Msg as Msg
import Conf (Conf (..))
import qualified LoginSession
-import Model.Init (getInit)
import qualified Model.Query as Query
import qualified Model.SignIn as SignIn
-import qualified Model.User as User
-import Secure (getUserFromToken)
+import qualified Persistence.Init as InitPersistence
+import qualified Persistence.User as UserPersistence
+import qualified Secure
import qualified SendMail
import qualified Text.Email.Validate as Email
import qualified View.Mail.SignIn as SignIn
@@ -39,16 +39,16 @@ get conf = do
mbLoggedUser <- getLoggedUser
case mbLoggedUser of
Nothing ->
- return . InitEmpty . Right $ Nothing
+ return InitEmpty
Just user ->
- liftIO . Query.run . fmap InitSuccess $ getInit user conf
+ liftIO . Query.run . fmap InitSuccess $ InitPersistence.getInit user conf
S.html $ page initResult
askSignIn :: Conf -> SignIn -> ActionM ()
askSignIn conf (SignIn email) =
if Email.isValid (TE.encodeUtf8 email)
then do
- maybeUser <- liftIO . Query.run $ User.get email
+ maybeUser <- liftIO . Query.run $ UserPersistence.get email
case maybeUser of
Just user -> do
token <- liftIO . Query.run $ SignIn.createSignInToken email
@@ -71,7 +71,7 @@ trySignIn conf token = do
userOrError <- validateSignIn conf token
case userOrError of
Left errorKey ->
- S.html $ page (InitEmpty . Left . Msg.get $ errorKey)
+ S.html $ page (InitError $ Msg.get errorKey)
Right _ ->
S.redirect "/"
@@ -100,7 +100,7 @@ validateSignIn conf textToken = do
LoginSession.put conf (SignIn.token signIn)
mbUser <- liftIO . Query.run $ do
SignIn.signInTokenToUsed . SignIn.id $ signIn
- User.get . SignIn.email $ signIn
+ UserPersistence.get . SignIn.email $ signIn
return $ case mbUser of
Nothing -> Left Msg.Secure_Unauthorized
Just user -> Right user
@@ -112,7 +112,7 @@ getLoggedUser = do
Nothing ->
return Nothing
Just token -> do
- liftIO . Query.run . getUserFromToken $ token
+ liftIO . Query.run . Secure.getUserFromToken $ token
signOut :: Conf -> ActionM ()
signOut conf = LoginSession.delete conf >> S.status ok200
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
index f2af6c9..e1936f0 100644
--- a/server/src/Controller/Payment.hs
+++ b/server/src/Controller/Payment.hs
@@ -5,54 +5,54 @@ module Controller.Payment
, deleteOwn
) where
-import Control.Monad.IO.Class (liftIO)
-import Network.HTTP.Types.Status (badRequest400, ok200)
+import Control.Monad.IO.Class (liftIO)
+import qualified Network.HTTP.Types.Status as Status
import Web.Scotty
-import Common.Model (CreatePayment (..),
- EditPayment (..), PaymentId,
- User (..))
+import Common.Model (CreatePayment (..),
+ EditPayment (..), PaymentId,
+ User (..))
-import Json (jsonId)
-import qualified Model.Payment as Payment
-import qualified Model.PaymentCategory as PaymentCategory
-import qualified Model.Query as Query
+import qualified Json
+import qualified Model.Query as Query
+import qualified Persistence.Payment as PaymentPersistence
+import qualified Persistence.PaymentCategory as PaymentCategoryPersistence
import qualified Secure
list :: ActionM ()
list =
Secure.loggedAction (\_ ->
- (liftIO . Query.run $ Payment.listActive) >>= json
+ (liftIO . Query.run $ PaymentPersistence.listActive) >>= json
)
create :: CreatePayment -> ActionM ()
create (CreatePayment name cost date category frequency) =
Secure.loggedAction (\user ->
(liftIO . Query.run $ do
- PaymentCategory.save name category
- Payment.create (_user_id user) name cost date frequency
- ) >>= jsonId
+ PaymentCategoryPersistence.save name category
+ PaymentPersistence.create (_user_id user) name cost date frequency
+ ) >>= Json.jsonId
)
editOwn :: EditPayment -> ActionM ()
editOwn (EditPayment paymentId name cost date category frequency) =
Secure.loggedAction (\user -> do
updated <- liftIO . Query.run $ do
- edited <- Payment.editOwn (_user_id user) paymentId name cost date frequency
+ edited <- PaymentPersistence.editOwn (_user_id user) paymentId name cost date frequency
_ <- if edited
- then PaymentCategory.save name category >> return ()
+ then PaymentCategoryPersistence.save name category >> return ()
else return ()
return edited
if updated
- then status ok200
- else status badRequest400
+ then status Status.ok200
+ else status Status.badRequest400
)
deleteOwn :: PaymentId -> ActionM ()
deleteOwn paymentId =
Secure.loggedAction (\user -> do
- deleted <- liftIO . Query.run $ Payment.deleteOwn (_user_id user) paymentId
+ deleted <- liftIO . Query.run $ PaymentPersistence.deleteOwn (_user_id user) paymentId
if deleted
- then status ok200
- else status badRequest400
+ then status Status.ok200
+ else status Status.badRequest400
)
diff --git a/server/src/Design/Form.hs b/server/src/Design/Form.hs
index be0e74f..0385cb4 100644
--- a/server/src/Design/Form.hs
+++ b/server/src/Design/Form.hs
@@ -53,8 +53,10 @@ design = do
right (px 0)
top (px 27)
zIndex inputZIndex
- hover & "svg path" ? do
- "fill" -: "rgb(220, 220, 220)"
+ svg ? "path" ?
+ ("fill" -: Color.toString Color.silver)
+ hover & svg ? "path" ?
+ ("fill" -: Color.toString (Color.silver -. 25))
(input # ".filled" |+ label) <> (input # focus |+ label) ? do
top (px 0)
@@ -108,18 +110,18 @@ design = do
fontWeight bold
".selectInput" ? do
+ marginBottom (em 1)
label ? do
display block
marginBottom (px 10)
fontSize (pct 80)
select ? do
+ width (pct 100)
backgroundColor Color.white
border solid (px 1) Color.silver
sym borderRadius (px 3)
sym2 padding (px 5) (px 8)
- option ? do
- firstChild & display none
- sym2 padding (px 5) (px 8)
+ option ? sym2 padding (px 5) (px 8)
".error" & do
select ? borderColor Color.chestnutRose
".errorMessage" ? do
diff --git a/server/src/Design/Modal.hs b/server/src/Design/Modal.hs
index 2612257..ce427c0 100644
--- a/server/src/Design/Modal.hs
+++ b/server/src/Design/Modal.hs
@@ -9,19 +9,18 @@ import Clay
design :: Css
design = do
- ".curtain" ? do
+ ".modalCurtain" ? do
position fixed
- cursor pointer
top (px 0)
left (px 0)
width (pct 100)
height (pct 100)
- backgroundColor (rgba 0 0 0 0.5)
+ backgroundColor (rgba 0 0 0 0.7)
zIndex 1000
opacity 1
transition "all" (sec 0.2) ease (sec 0)
- ".content" ? do
+ ".modalContent" ? do
minWidth (px 270)
position fixed
top (pct 25)
@@ -29,7 +28,6 @@ design = do
"transform" -: "translate(-50%, -25%)"
zIndex 1000
backgroundColor white
- sym padding (px 20)
sym borderRadius (px 5)
boxShadow (px 0) (px 0) (px 15) (rgba 0 0 0 0.5)
diff --git a/server/src/Design/View/Payment.hs b/server/src/Design/View/Payment.hs
index 0d59fa0..2102ff8 100644
--- a/server/src/Design/View/Payment.hs
+++ b/server/src/Design/View/Payment.hs
@@ -4,6 +4,7 @@ module Design.View.Payment
import Clay
+import qualified Design.View.Payment.Add as Add
import qualified Design.View.Payment.Header as Header
import qualified Design.View.Payment.Pages as Pages
import qualified Design.View.Payment.Table as Table
@@ -11,5 +12,6 @@ import qualified Design.View.Payment.Table as Table
design :: Css
design = do
".header" ? Header.design
+ ".add" ? Add.design
".table" ? Table.design
".pages" ? Pages.design
diff --git a/server/src/Design/View/Payment/Add.hs b/server/src/Design/View/Payment/Add.hs
new file mode 100644
index 0000000..199ad36
--- /dev/null
+++ b/server/src/Design/View/Payment/Add.hs
@@ -0,0 +1,32 @@
+module Design.View.Payment.Add
+ ( design
+ ) where
+
+import Clay
+
+import qualified Design.Color as Color
+import qualified Design.Constants as Constants
+import qualified Design.Helper as Helper
+
+design :: Css
+design = do
+ ".addHeader" ? do
+ backgroundColor Color.chestnutRose
+ fontSize (px 18)
+ color Color.white
+ sym padding (px 20)
+ textAlign (alignSide sideCenter)
+ borderRadius (px 5) (px 5) (px 0) (px 0)
+
+ ".addContent" ? do
+ sym padding (px 20)
+
+ ".buttons" ? do
+ display flex
+ justifyContent spaceAround
+ marginTop (em 1.5)
+
+ ".confirm" ?
+ Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten
+ ".undo" ?
+ Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten
diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/Header.hs
index 80c5436..0cb5b5d 100644
--- a/server/src/Design/View/Payment/Header.hs
+++ b/server/src/Design/View/Payment/Header.hs
@@ -6,8 +6,6 @@ import Data.Monoid ((<>))
import Clay
-import Design.Constants
-
import qualified Design.Color as Color
import qualified Design.Constants as Constants
import qualified Design.Helper as Helper
@@ -17,8 +15,8 @@ design :: Css
design = do
Media.desktop $ marginBottom (em 3)
Media.mobileTablet $ marginBottom (em 2)
- marginLeft (pct blockPercentMargin)
- marginRight (pct blockPercentMargin)
+ marginLeft (pct Constants.blockPercentMargin)
+ marginRight (pct Constants.blockPercentMargin)
".payerAndAdd" ? do
Media.tabletDesktop $ display flex
@@ -55,9 +53,6 @@ design = do
".textInput" ? do
display inlineBlock
marginBottom (px 0)
- button ? do
- svg ? "path" ? ("fill" -: Color.toString Color.silver)
- hover & svg ? "path" ? ("fill" -: Color.toString (Color.silver -. 25))
Media.tabletDesktop $ marginRight (px 30)
Media.mobile $ do
diff --git a/server/src/Job/MonthlyPayment.hs b/server/src/Job/MonthlyPayment.hs
index 907be2b..dfbe8b4 100644
--- a/server/src/Job/MonthlyPayment.hs
+++ b/server/src/Job/MonthlyPayment.hs
@@ -2,19 +2,19 @@ module Job.MonthlyPayment
( monthlyPayment
) where
-import Data.Time.Clock (UTCTime, getCurrentTime)
+import Data.Time.Clock (UTCTime, getCurrentTime)
-import Common.Model (Frequency (..), Payment (..))
+import Common.Model (Frequency (..), Payment (..))
+import qualified Common.Util.Time as Time
-import qualified Model.Payment as Payment
-import qualified Model.Query as Query
-import Util.Time (timeToDay)
+import qualified Model.Query as Query
+import qualified Persistence.Payment as PaymentPersistence
monthlyPayment :: Maybe UTCTime -> IO UTCTime
monthlyPayment _ = do
- monthlyPayments <- Query.run Payment.listActiveMonthlyOrderedByName
+ monthlyPayments <- Query.run PaymentPersistence.listActiveMonthlyOrderedByName
now <- getCurrentTime
- actualDay <- timeToDay now
+ actualDay <- Time.timeToDay now
let punctualPayments = map
(\p -> p
{ _payment_frequency = Punctual
@@ -22,5 +22,5 @@ monthlyPayment _ = do
, _payment_createdAt = now
})
monthlyPayments
- _ <- Query.run (Payment.createMany punctualPayments)
+ _ <- Query.run (PaymentPersistence.createMany punctualPayments)
return now
diff --git a/server/src/Job/WeeklyReport.hs b/server/src/Job/WeeklyReport.hs
index 38d88b5..203c4e8 100644
--- a/server/src/Job/WeeklyReport.hs
+++ b/server/src/Job/WeeklyReport.hs
@@ -5,10 +5,10 @@ module Job.WeeklyReport
import Data.Time.Clock (UTCTime, getCurrentTime)
import Conf (Conf)
-import qualified Model.Income as Income
-import qualified Model.Payment as Payment
import qualified Model.Query as Query
-import qualified Model.User as User
+import qualified Persistence.Income as IncomePersistence
+import qualified Persistence.Payment as PaymentPersistence
+import qualified Persistence.User as UserPersistence
import qualified SendMail
import qualified View.Mail.WeeklyReport as WeeklyReport
@@ -19,7 +19,7 @@ weeklyReport conf mbLastExecution = do
Nothing -> return ()
Just lastExecution -> do
(payments, incomes, users) <- Query.run $
- (,,) <$> Payment.listPunctual <*> Income.list <*> User.list
+ (,,) <$> PaymentPersistence.listPunctual <*> IncomePersistence.list <*> UserPersistence.list
_ <- SendMail.sendMail conf (WeeklyReport.mail conf users payments incomes lastExecution now)
return ()
return now
diff --git a/server/src/Model/IncomeResource.hs b/server/src/Model/IncomeResource.hs
new file mode 100644
index 0000000..6ab5f18
--- /dev/null
+++ b/server/src/Model/IncomeResource.hs
@@ -0,0 +1,15 @@
+module Model.IncomeResource
+ ( IncomeResource(..)
+ ) where
+
+import Common.Model (Income (..))
+
+import Resource (Resource, resourceCreatedAt, resourceDeletedAt,
+ resourceEditedAt)
+
+newtype IncomeResource = IncomeResource Income
+
+instance Resource IncomeResource where
+ resourceCreatedAt (IncomeResource i) = _income_createdAt i
+ resourceEditedAt (IncomeResource i) = _income_editedAt i
+ resourceDeletedAt (IncomeResource i) = _income_deletedAt i
diff --git a/server/src/Model/Init.hs b/server/src/Model/Init.hs
deleted file mode 100644
index 0a0ffc7..0000000
--- a/server/src/Model/Init.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-module Model.Init
- ( getInit
- ) where
-
-import Common.Model (Init (Init), User (..))
-
-import Conf (Conf)
-import qualified Conf
-import qualified Model.Category as Category
-import qualified Model.Income as Income
-import qualified Model.Payment as Payment
-import qualified Model.PaymentCategory as PaymentCategory
-import Model.Query (Query)
-import qualified Model.User as User
-
-getInit :: User -> Conf -> Query Init
-getInit user conf =
- Init <$>
- User.list <*>
- (return . _user_id $ user) <*>
- Payment.listActive <*>
- Income.list <*>
- Category.list <*>
- PaymentCategory.list <*>
- (return . Conf.currency $ conf)
diff --git a/server/src/Model/PaymentResource.hs b/server/src/Model/PaymentResource.hs
new file mode 100644
index 0000000..1ea978c
--- /dev/null
+++ b/server/src/Model/PaymentResource.hs
@@ -0,0 +1,15 @@
+module Model.PaymentResource
+ ( PaymentResource(..)
+ ) where
+
+import Common.Model (Payment (..))
+
+import Resource (Resource, resourceCreatedAt, resourceDeletedAt,
+ resourceEditedAt)
+
+newtype PaymentResource = PaymentResource Payment
+
+instance Resource PaymentResource where
+ resourceCreatedAt (PaymentResource p) = _payment_createdAt p
+ resourceEditedAt (PaymentResource p) = _payment_editedAt p
+ resourceDeletedAt (PaymentResource p) = _payment_deletedAt p
diff --git a/server/src/Model/User.hs b/server/src/Model/User.hs
deleted file mode 100644
index 8dc1fc8..0000000
--- a/server/src/Model/User.hs
+++ /dev/null
@@ -1,48 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Model.User
- ( list
- , get
- , create
- , delete
- ) where
-
-import Data.Maybe (listToMaybe)
-import Data.Text (Text)
-import Data.Time.Clock (getCurrentTime)
-import Database.SQLite.Simple (FromRow (fromRow), Only (Only))
-import qualified Database.SQLite.Simple as SQLite
-import Prelude hiding (id)
-
-import Common.Model (User (..), UserId)
-
-import Model.Query (Query (Query))
-
-instance FromRow User where
- fromRow = User <$> SQLite.field <*> SQLite.field <*> SQLite.field <*> SQLite.field
-
-list :: Query [User]
-list = Query (\conn -> SQLite.query_ conn "SELECT * from user ORDER BY creation DESC")
-
-get :: Text -> Query (Maybe User)
-get userEmail =
- Query (\conn -> listToMaybe <$>
- SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail)
- )
-
-create :: Text -> Text -> Query UserId
-create userEmail userName =
- Query (\conn -> do
- now <- getCurrentTime
- SQLite.execute
- conn
- "INSERT INTO user (creation, email, name) VALUES (?, ?, ?)"
- (now, userEmail, userName)
- SQLite.lastInsertRowId conn
- )
-
-delete :: Text -> Query ()
-delete userEmail =
- Query (\conn ->
- SQLite.execute conn "DELETE FROM user WHERE email = ?" (Only userEmail)
- )
diff --git a/server/src/Model/Category.hs b/server/src/Persistence/Category.hs
index ee406bc..2afe5db 100644
--- a/server/src/Model/Category.hs
+++ b/server/src/Persistence/Category.hs
@@ -1,6 +1,4 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Model.Category
+module Persistence.Category
( list
, create
, edit
@@ -18,19 +16,22 @@ import Common.Model (Category (..), CategoryId)
import Model.Query (Query (Query))
-instance FromRow Category where
- fromRow = Category <$>
+newtype Row = Row Category
+
+instance FromRow Row where
+ fromRow = Row <$> (Category <$>
SQLite.field <*>
SQLite.field <*>
SQLite.field <*>
SQLite.field <*>
SQLite.field <*>
- SQLite.field
+ SQLite.field)
list :: Query [Category]
list =
Query (\conn ->
- SQLite.query_ conn "SELECT * FROM category WHERE deleted_at IS NULL"
+ map (\(Row c) -> c) <$>
+ SQLite.query_ conn "SELECT * FROM category WHERE deleted_at IS NULL"
)
create :: Text -> Text -> Query CategoryId
@@ -47,8 +48,8 @@ create categoryName categoryColor =
edit :: CategoryId -> Text -> Text -> Query Bool
edit categoryId categoryName categoryColor =
Query (\conn -> do
- mbCategory <- listToMaybe <$>
- (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId) :: IO [Category])
+ mbCategory <- fmap (\(Row c) -> c) . listToMaybe <$>
+ (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId))
if isJust mbCategory
then do
now <- getCurrentTime
@@ -64,8 +65,8 @@ edit categoryId categoryName categoryColor =
delete :: CategoryId -> Query Bool
delete categoryId =
Query (\conn -> do
- mbCategory <- listToMaybe <$>
- (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId) :: IO [Category])
+ mbCategory <- fmap (\(Row c) -> c) . listToMaybe <$>
+ (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId))
if isJust mbCategory
then do
now <- getCurrentTime
diff --git a/server/src/Model/Frequency.hs b/server/src/Persistence/Frequency.hs
index c29cf37..edaa844 100644
--- a/server/src/Model/Frequency.hs
+++ b/server/src/Persistence/Frequency.hs
@@ -1,6 +1,6 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Model.Frequency () where
+module Persistence.Frequency
+ ( FrequencyField(..)
+ ) where
import qualified Data.Text as T
import Database.SQLite.Simple (SQLData (SQLText))
@@ -11,10 +11,13 @@ import Database.SQLite.Simple.ToField (ToField (toField))
import Common.Model (Frequency)
-instance FromField Frequency where
- fromField field = case fieldData field of
- SQLText text -> Ok (read (T.unpack text) :: Frequency)
- _ -> Errors [error "SQLText field required for frequency"]
+newtype FrequencyField = FrequencyField Frequency
+
+instance FromField FrequencyField where
+ fromField field =
+ case fieldData field of
+ SQLText text -> Ok (FrequencyField (read (T.unpack text) :: Frequency))
+ _ -> Errors [error "SQLText field required for frequency"]
-instance ToField Frequency where
- toField frequency = SQLText . T.pack . show $ frequency
+instance ToField FrequencyField where
+ toField (FrequencyField f) = SQLText . T.pack . show $ f
diff --git a/server/src/Model/Income.hs b/server/src/Persistence/Income.hs
index 4938e50..a863f85 100644
--- a/server/src/Model/Income.hs
+++ b/server/src/Persistence/Income.hs
@@ -1,6 +1,4 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Model.Income
+module Persistence.Income
( list
, create
, editOwn
@@ -18,26 +16,25 @@ import Common.Model (Income (..), IncomeId, User (..),
UserId)
import Model.Query (Query (Query))
-import Resource (Resource, resourceCreatedAt,
- resourceDeletedAt, resourceEditedAt)
-instance Resource Income where
- resourceCreatedAt = _income_createdAt
- resourceEditedAt = _income_editedAt
- resourceDeletedAt = _income_deletedAt
+newtype Row = Row Income
-instance FromRow Income where
- fromRow = Income <$>
+instance FromRow Row where
+ fromRow = Row <$> (Income <$>
SQLite.field <*>
SQLite.field <*>
SQLite.field <*>
SQLite.field <*>
SQLite.field <*>
SQLite.field <*>
- SQLite.field
+ SQLite.field)
list :: Query [Income]
-list = Query (\conn -> SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL")
+list =
+ Query (\conn ->
+ map (\(Row i) -> i) <$>
+ SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL"
+ )
create :: UserId -> Day -> Int -> Query IncomeId
create incomeUserId incomeDate incomeAmount =
@@ -53,7 +50,8 @@ create incomeUserId incomeDate incomeAmount =
editOwn :: UserId -> IncomeId -> Day -> Int -> Query Bool
editOwn incomeUserId incomeId incomeDate incomeAmount =
Query (\conn -> do
- mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId)
+ mbIncome <- fmap (\(Row i) -> i) . listToMaybe <$>
+ SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId)
case mbIncome of
Just income ->
if _income_userId income == incomeUserId
@@ -73,7 +71,9 @@ editOwn incomeUserId incomeId incomeDate incomeAmount =
deleteOwn :: User -> IncomeId -> Query Bool
deleteOwn user incomeId =
Query (\conn -> do
- mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId)
+ mbIncome <-
+ fmap (\(Row i) -> i) . listToMaybe <$>
+ SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId)
case mbIncome of
Just income ->
if _income_userId income == _user_id user
diff --git a/server/src/Persistence/Init.hs b/server/src/Persistence/Init.hs
new file mode 100644
index 0000000..74d9172
--- /dev/null
+++ b/server/src/Persistence/Init.hs
@@ -0,0 +1,25 @@
+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)
diff --git a/server/src/Model/Payment.hs b/server/src/Persistence/Payment.hs
index 5b29409..32600d7 100644
--- a/server/src/Model/Payment.hs
+++ b/server/src/Persistence/Payment.hs
@@ -1,6 +1,4 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Model.Payment
+module Persistence.Payment
( Payment(..)
, find
, listActive
@@ -26,71 +24,73 @@ import Prelude hiding (id)
import Common.Model (Frequency (..), Payment (..),
PaymentId, UserId)
-import Model.Frequency ()
import Model.Query (Query (Query))
-import Resource (Resource, resourceCreatedAt,
- resourceDeletedAt,
- resourceEditedAt)
+import Persistence.Frequency (FrequencyField (..))
-instance Resource Payment where
- resourceCreatedAt = _payment_createdAt
- resourceEditedAt = _payment_editedAt
- resourceDeletedAt = _payment_deletedAt
+newtype Row = Row Payment
-instance FromRow Payment where
- fromRow = Payment <$>
- SQLite.field <*>
+instance FromRow Row where
+ fromRow = Row <$> (Payment <$>
SQLite.field <*>
SQLite.field <*>
SQLite.field <*>
SQLite.field <*>
SQLite.field <*>
+ (fmap (\(FrequencyField f) -> f) $ SQLite.field) <*>
SQLite.field <*>
SQLite.field <*>
- SQLite.field
+ SQLite.field)
+
+newtype InsertRow = InsertRow Payment
-instance ToRow Payment where
- toRow p =
+instance ToRow InsertRow where
+ toRow (InsertRow p) =
[ toField (_payment_user p)
, toField (_payment_name p)
, toField (_payment_cost p)
, toField (_payment_date p)
- , toField (_payment_frequency p)
+ , toField (FrequencyField (_payment_frequency p))
, toField (_payment_createdAt p)
]
find :: PaymentId -> Query (Maybe Payment)
find paymentId =
- Query (\conn -> listToMaybe <$>
- SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId)
+ Query (\conn -> do
+ fmap (\(Row p) -> p) . listToMaybe <$>
+ SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId)
)
listActive :: Query [Payment]
listActive =
- Query (\conn ->
- SQLite.query_ conn "SELECT * FROM payment WHERE deleted_at IS NULL"
+ Query (\conn -> do
+ map (\(Row p) -> p) <$>
+ SQLite.query_ conn "SELECT * FROM payment WHERE deleted_at IS NULL"
)
listPunctual :: Query [Payment]
listPunctual =
- Query (\conn ->
- SQLite.query
- conn
- (SQLite.Query "SELECT * FROM payment WHERE frequency = ?")
- (Only Punctual))
+ Query (\conn -> do
+ map (\(Row p) -> p) <$>
+ SQLite.query
+ conn
+ (SQLite.Query "SELECT * FROM payment WHERE frequency = ?")
+ (Only (FrequencyField Punctual))
+ )
listActiveMonthlyOrderedByName :: Query [Payment]
listActiveMonthlyOrderedByName =
- Query (\conn ->
- SQLite.query
- conn
- (SQLite.Query $ T.intercalate " "
- [ "SELECT *"
- , "FROM payment"
- , "WHERE deleted_at IS NULL AND frequency = ?"
- , "ORDER BY name DESC"
- ])
- (Only Monthly))
+ Query (\conn -> do
+ map (\(Row p) -> p) <$>
+ SQLite.query
+ conn
+ (SQLite.Query $ T.intercalate " "
+ [ "SELECT *"
+ , "FROM payment"
+ , "WHERE deleted_at IS NULL AND frequency = ?"
+ , "ORDER BY name DESC"
+ ])
+ (Only (FrequencyField Monthly))
+ )
create :: UserId -> Text -> Int -> Day -> Frequency -> Query PaymentId
create userId paymentName paymentCost paymentDate paymentFrequency =
@@ -102,7 +102,7 @@ create userId paymentName paymentCost paymentDate paymentFrequency =
[ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)"
, "VALUES (?, ?, ?, ?, ?, ?)"
])
- (userId, paymentName, paymentCost, paymentDate, paymentFrequency, now)
+ (userId, paymentName, paymentCost, paymentDate, FrequencyField paymentFrequency, now)
SQLite.lastInsertRowId conn
)
@@ -115,13 +115,13 @@ createMany payments =
[ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)"
, "VALUES (?, ?, ?, ?, ?, ?)"
])
- payments
+ (map InsertRow payments)
)
editOwn :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool
editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency =
Query (\conn -> do
- mbPayment <- listToMaybe <$>
+ mbPayment <- fmap (\(Row p) -> p) . listToMaybe <$>
SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId)
case mbPayment of
Just payment ->
@@ -139,7 +139,7 @@ editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency =
, " frequency = ?"
, "WHERE id = ?"
])
- (now, paymentName, paymentCost, paymentDate, paymentFrequency, paymentId)
+ (now, paymentName, paymentCost, paymentDate, FrequencyField paymentFrequency, paymentId)
return True
else
return False
@@ -153,7 +153,7 @@ deleteOwn userId paymentId =
mbPayment <- listToMaybe <$>
SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId)
case mbPayment of
- Just payment ->
+ Just (Row payment) ->
if _payment_user payment == userId
then do
now <- getCurrentTime
diff --git a/server/src/Model/PaymentCategory.hs b/server/src/Persistence/PaymentCategory.hs
index c60c1a2..1e377b1 100644
--- a/server/src/Model/PaymentCategory.hs
+++ b/server/src/Persistence/PaymentCategory.hs
@@ -1,6 +1,4 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Model.PaymentCategory
+module Persistence.PaymentCategory
( list
, listByCategory
, save
@@ -18,33 +16,40 @@ import qualified Common.Util.Text as T
import Model.Query (Query (Query))
-instance FromRow PaymentCategory where
- fromRow = PaymentCategory <$>
+newtype Row = Row PaymentCategory
+
+instance FromRow Row where
+ fromRow = Row <$> (PaymentCategory <$>
SQLite.field <*>
SQLite.field <*>
SQLite.field <*>
SQLite.field <*>
- SQLite.field
+ SQLite.field)
list :: Query [PaymentCategory]
-list = Query (\conn -> SQLite.query_ conn "SELECT * from payment_category")
+list =
+ Query (\conn -> do
+ map (\(Row pc) -> pc) <$>
+ SQLite.query_ conn "SELECT * from payment_category"
+ )
listByCategory :: CategoryId -> Query [PaymentCategory]
listByCategory cat =
- Query (\conn ->
- SQLite.query conn "SELECT * FROM payment_category WHERE category = ?" (Only cat)
+ Query (\conn -> do
+ map (\(Row pc) -> pc) <$>
+ SQLite.query conn "SELECT * FROM payment_category WHERE category = ?" (Only cat)
)
save :: Text -> CategoryId -> Query ()
save newName categoryId =
Query (\conn -> do
now <- getCurrentTime
- mbPaymentCategory <- listToMaybe <$>
+ hasPaymentCategory <- isJust <$> listToMaybe <$>
(SQLite.query
conn
"SELECT * FROM payment_category WHERE name = ?"
- (Only (formatPaymentName newName)) :: IO [PaymentCategory])
- if isJust mbPaymentCategory
+ (Only (formatPaymentName newName)) :: IO [Row])
+ if hasPaymentCategory
then
SQLite.execute
conn
diff --git a/server/src/Persistence/User.hs b/server/src/Persistence/User.hs
new file mode 100644
index 0000000..4ec2dcf
--- /dev/null
+++ b/server/src/Persistence/User.hs
@@ -0,0 +1,37 @@
+module Persistence.User
+ ( list
+ , get
+ ) where
+
+import Data.Maybe (listToMaybe)
+import Data.Text (Text)
+import Database.SQLite.Simple (FromRow (fromRow), Only (Only))
+import qualified Database.SQLite.Simple as SQLite
+import Prelude hiding (id)
+
+import Common.Model (User (..))
+
+import Model.Query (Query (Query))
+
+newtype Row = Row User
+
+instance FromRow Row where
+ fromRow = Row <$> (User <$>
+ SQLite.field <*>
+ SQLite.field <*>
+ SQLite.field <*>
+ SQLite.field)
+
+list :: Query [User]
+list =
+ Query (\conn -> do
+ map (\(Row u) -> u) <$>
+ SQLite.query_ conn "SELECT * from user ORDER BY creation DESC"
+ )
+
+get :: Text -> Query (Maybe User)
+get userEmail =
+ Query (\conn -> do
+ fmap (\(Row u) -> u) . listToMaybe <$>
+ SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail)
+ )
diff --git a/server/src/Secure.hs b/server/src/Secure.hs
index 6e5b998..4fb2333 100644
--- a/server/src/Secure.hs
+++ b/server/src/Secure.hs
@@ -16,7 +16,7 @@ import qualified LoginSession
import Model.Query (Query)
import qualified Model.Query as Query
import qualified Model.SignIn as SignIn
-import qualified Model.User as User
+import qualified Persistence.User as UserPersistence
loggedAction :: (User -> ActionM ()) -> ActionM ()
loggedAction action = do
@@ -39,6 +39,6 @@ getUserFromToken token = do
mbSignIn <- SignIn.getSignIn token
case mbSignIn of
Just signIn ->
- User.get (SignIn.email signIn)
+ UserPersistence.get (SignIn.email signIn)
Nothing ->
return Nothing
diff --git a/server/src/SendMail.hs b/server/src/SendMail.hs
index 3b17a0a..13d4072 100644
--- a/server/src/SendMail.hs
+++ b/server/src/SendMail.hs
@@ -43,6 +43,7 @@ mockMailMessage mail = T.concat $
, ")"
, "\n"
, body mail
+ , "\n"
]
getMimeMail :: Mail -> M.Mail
diff --git a/server/src/Util/Time.hs b/server/src/Util/Time.hs
index 3e0856d..4a29fcc 100644
--- a/server/src/Util/Time.hs
+++ b/server/src/Util/Time.hs
@@ -1,25 +1,22 @@
module Util.Time
( belongToCurrentMonth
, belongToCurrentWeek
- , timeToDay
) where
-import Data.Time.Calendar
+import Data.Time.Calendar (toGregorian)
import Data.Time.Calendar.WeekDate (toWeekDate)
import Data.Time.Clock (UTCTime, getCurrentTime)
-import Data.Time.LocalTime
+
+import qualified Common.Util.Time as Time
belongToCurrentMonth :: UTCTime -> IO Bool
belongToCurrentMonth time = do
- (timeYear, timeMonth, _) <- toGregorian <$> timeToDay time
- (actualYear, actualMonth, _) <- toGregorian <$> (getCurrentTime >>= timeToDay)
+ (timeYear, timeMonth, _) <- toGregorian <$> Time.timeToDay time
+ (actualYear, actualMonth, _) <- toGregorian <$> (getCurrentTime >>= Time.timeToDay)
return (actualYear == timeYear && actualMonth == timeMonth)
belongToCurrentWeek :: UTCTime -> IO Bool
belongToCurrentWeek time = do
- (timeYear, timeWeek, _) <- toWeekDate <$> timeToDay time
- (actualYear, actualWeek, _) <- toWeekDate <$> (getCurrentTime >>= timeToDay)
+ (timeYear, timeWeek, _) <- toWeekDate <$> Time.timeToDay time
+ (actualYear, actualWeek, _) <- toWeekDate <$> (getCurrentTime >>= Time.timeToDay)
return (actualYear == timeYear && actualWeek == timeWeek)
-
-timeToDay :: UTCTime -> IO Day
-timeToDay time = localDay . (flip utcToLocalTime time) <$> getTimeZone time
diff --git a/server/src/View/Mail/WeeklyReport.hs b/server/src/View/Mail/WeeklyReport.hs
index 5418880..7e88d98 100644
--- a/server/src/View/Mail/WeeklyReport.hs
+++ b/server/src/View/Mail/WeeklyReport.hs
@@ -2,28 +2,28 @@ module View.Mail.WeeklyReport
( mail
) where
-import Data.List (sortOn)
-import Data.Map (Map)
-import qualified Data.Map as M
-import Data.Maybe (catMaybes, fromMaybe)
-import Data.Monoid ((<>))
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.Time.Clock (UTCTime)
+import Data.List (sortOn)
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe (catMaybes, fromMaybe)
+import Data.Monoid ((<>))
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Clock (UTCTime)
-import Common.Model (ExceedingPayer (..), Income (..),
- Payment (..), User (..), UserId)
-import qualified Common.Model as CM
-import qualified Common.Msg as Msg
-import qualified Common.View.Format as Format
+import Common.Model (ExceedingPayer (..), Income (..),
+ Payment (..), User (..), UserId)
+import qualified Common.Model as CM
+import qualified Common.Msg as Msg
+import qualified Common.View.Format as Format
-import Conf (Conf)
-import qualified Conf as Conf
-import qualified Model.Income ()
-import Model.Mail (Mail (Mail))
-import qualified Model.Mail as M
-import Model.Payment ()
-import Resource (Status (..), groupByStatus, statuses)
+import Conf (Conf)
+import qualified Conf as Conf
+import Model.IncomeResource (IncomeResource (..))
+import Model.Mail (Mail (Mail))
+import qualified Model.Mail as M
+import Model.PaymentResource (PaymentResource (..))
+import Resource (Status (..), groupByStatus, statuses)
mail :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Mail
mail conf users payments incomes start end =
@@ -42,8 +42,11 @@ body :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Text
body conf users payments incomes start end =
T.intercalate "\n" $
[ exceedingPayers conf end users incomes (filter (null . _payment_deletedAt) payments)
- , operations conf users (groupByStatus start end payments) (groupByStatus start end incomes)
+ , operations conf users paymentsGroupedByStatus incomesGroupedByStatus
]
+ where
+ paymentsGroupedByStatus = groupByStatus start end . map PaymentResource $ payments
+ incomesGroupedByStatus = groupByStatus start end . map IncomeResource $ incomes
exceedingPayers :: Conf -> UTCTime -> [User] -> [Income] -> [Payment] -> Text
exceedingPayers conf time users incomes payments =
@@ -58,7 +61,7 @@ exceedingPayers conf time users incomes payments =
, "\n"
]
-operations :: Conf -> [User] -> Map Status [Payment] -> Map Status [Income] -> Text
+operations :: Conf -> [User] -> Map Status [PaymentResource] -> Map Status [IncomeResource] -> Text
operations conf users paymentsByStatus incomesByStatus =
if M.null paymentsByStatus && M.null incomesByStatus
then
@@ -69,7 +72,7 @@ operations conf users paymentsByStatus incomesByStatus =
, map (\s -> incomeSection s conf users <$> M.lookup s incomesByStatus) statuses
]
-paymentSection :: Status -> Conf -> [User] -> [Payment] -> Text
+paymentSection :: Status -> Conf -> [User] -> [PaymentResource] -> Text
paymentSection status conf users payments =
section sectionTitle sectionItems
where count = length payments
@@ -77,7 +80,7 @@ paymentSection status conf users payments =
Created -> if count > 1 then Msg.WeeklyReport_PaymentsCreated count else Msg.WeeklyReport_PaymentCreated count
Edited -> if count > 1 then Msg.WeeklyReport_PaymentsEdited count else Msg.WeeklyReport_PaymentEdited count
Deleted -> if count > 1 then Msg.WeeklyReport_PaymentsDeleted count else Msg.WeeklyReport_PaymentDeleted count
- sectionItems = map (payedFor status conf users) . sortOn _payment_date $ payments
+ sectionItems = map (payedFor status conf users) . sortOn _payment_date . map (\(PaymentResource p) -> p) $ payments
payedFor :: Status -> Conf -> [User] -> Payment -> Text
payedFor status conf users payment =
@@ -89,7 +92,7 @@ payedFor status conf users payment =
for = _payment_name payment
at = Format.longDay $ _payment_date payment
-incomeSection :: Status -> Conf -> [User] -> [Income] -> Text
+incomeSection :: Status -> Conf -> [User] -> [IncomeResource] -> Text
incomeSection status conf users incomes =
section sectionTitle sectionItems
where count = length incomes
@@ -97,7 +100,7 @@ incomeSection status conf users incomes =
Created -> if count > 1 then Msg.WeeklyReport_IncomesCreated count else Msg.WeeklyReport_IncomeCreated count
Edited -> if count > 1 then Msg.WeeklyReport_IncomesEdited count else Msg.WeeklyReport_IncomeEdited count
Deleted -> if count > 1 then Msg.WeeklyReport_IncomesDeleted count else Msg.WeeklyReport_IncomeDeleted count
- sectionItems = map (isPayedFrom status conf users) . sortOn _income_date $ incomes
+ sectionItems = map (isPayedFrom status conf users) . sortOn _income_date . map (\(IncomeResource i) -> i) $ incomes
isPayedFrom :: Status -> Conf -> [User] -> Income -> Text
isPayedFrom status conf users income =