From 33b85b7f12798f5762d940ed5c30f775cdd7b751 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 28 Jan 2018 12:13:09 +0100 Subject: WIP --- server/server.cabal | 15 +-- server/src/Controller/Category.hs | 30 +++--- server/src/Controller/Income.hs | 8 +- server/src/Controller/Index.hs | 18 ++-- server/src/Controller/Payment.hs | 40 +++---- server/src/Design/Form.hs | 12 ++- server/src/Design/Modal.hs | 8 +- server/src/Design/View/Payment.hs | 2 + server/src/Design/View/Payment/Add.hs | 32 ++++++ server/src/Design/View/Payment/Header.hs | 9 +- server/src/Job/MonthlyPayment.hs | 16 +-- server/src/Job/WeeklyReport.hs | 8 +- server/src/Model/Category.hs | 78 -------------- server/src/Model/Frequency.hs | 20 ---- server/src/Model/Income.hs | 88 ---------------- server/src/Model/IncomeResource.hs | 15 +++ server/src/Model/Init.hs | 25 ----- server/src/Model/Payment.hs | 169 ------------------------------ server/src/Model/PaymentCategory.hs | 61 ----------- server/src/Model/PaymentResource.hs | 15 +++ server/src/Model/User.hs | 48 --------- server/src/Persistence/Category.hs | 79 ++++++++++++++ server/src/Persistence/Frequency.hs | 23 ++++ server/src/Persistence/Income.hs | 88 ++++++++++++++++ server/src/Persistence/Init.hs | 25 +++++ server/src/Persistence/Payment.hs | 169 ++++++++++++++++++++++++++++++ server/src/Persistence/PaymentCategory.hs | 66 ++++++++++++ server/src/Persistence/User.hs | 37 +++++++ server/src/Secure.hs | 4 +- server/src/SendMail.hs | 1 + server/src/Util/Time.hs | 17 ++- server/src/View/Mail/WeeklyReport.hs | 55 +++++----- 32 files changed, 670 insertions(+), 611 deletions(-) create mode 100644 server/src/Design/View/Payment/Add.hs delete mode 100644 server/src/Model/Category.hs delete mode 100644 server/src/Model/Frequency.hs delete mode 100644 server/src/Model/Income.hs create mode 100644 server/src/Model/IncomeResource.hs delete mode 100644 server/src/Model/Init.hs delete mode 100644 server/src/Model/Payment.hs delete mode 100644 server/src/Model/PaymentCategory.hs create mode 100644 server/src/Model/PaymentResource.hs delete mode 100644 server/src/Model/User.hs create mode 100644 server/src/Persistence/Category.hs create mode 100644 server/src/Persistence/Frequency.hs create mode 100644 server/src/Persistence/Income.hs create mode 100644 server/src/Persistence/Init.hs create mode 100644 server/src/Persistence/Payment.hs create mode 100644 server/src/Persistence/PaymentCategory.hs create mode 100644 server/src/Persistence/User.hs (limited to 'server') 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/Category.hs b/server/src/Model/Category.hs deleted file mode 100644 index ee406bc..0000000 --- a/server/src/Model/Category.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.Category - ( list - , create - , edit - , delete - ) where - -import Data.Maybe (isJust, 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 (Category (..), CategoryId) - -import Model.Query (Query (Query)) - -instance FromRow Category where - fromRow = Category <$> - 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" - ) - -create :: Text -> Text -> Query CategoryId -create categoryName categoryColor = - Query (\conn -> do - now <- getCurrentTime - SQLite.execute - conn - "INSERT INTO category (name, color, created_at) VALUES (?, ?, ?)" - (categoryName, categoryColor, now) - SQLite.lastInsertRowId conn - ) - -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]) - if isJust mbCategory - then do - now <- getCurrentTime - SQLite.execute - conn - "UPDATE category SET edited_at = ?, name = ?, color = ? WHERE id = ?" - (now, categoryName, categoryColor, categoryId) - return True - else - return False - ) - -delete :: CategoryId -> Query Bool -delete categoryId = - Query (\conn -> do - mbCategory <- listToMaybe <$> - (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId) :: IO [Category]) - if isJust mbCategory - then do - now <- getCurrentTime - SQLite.execute - conn - "UPDATE category SET deleted_at = ? WHERE id = ?" (now, categoryId) - return True - else - return False - ) diff --git a/server/src/Model/Frequency.hs b/server/src/Model/Frequency.hs deleted file mode 100644 index c29cf37..0000000 --- a/server/src/Model/Frequency.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.Frequency () where - -import qualified Data.Text as T -import Database.SQLite.Simple (SQLData (SQLText)) -import Database.SQLite.Simple.FromField (FromField (fromField), - fieldData) -import Database.SQLite.Simple.Ok (Ok (Errors, Ok)) -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"] - -instance ToField Frequency where - toField frequency = SQLText . T.pack . show $ frequency diff --git a/server/src/Model/Income.hs b/server/src/Model/Income.hs deleted file mode 100644 index 4938e50..0000000 --- a/server/src/Model/Income.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.Income - ( list - , create - , editOwn - , deleteOwn - ) where - -import Data.Maybe (listToMaybe) -import Data.Time.Calendar (Day) -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 (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 - -instance FromRow Income where - fromRow = Income <$> - 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") - -create :: UserId -> Day -> Int -> Query IncomeId -create incomeUserId incomeDate incomeAmount = - Query (\conn -> do - now <- getCurrentTime - SQLite.execute - conn - "INSERT INTO income (user_id, date, amount, created_at) VALUES (?, ?, ?, ?)" - (incomeUserId, incomeDate, incomeAmount, now) - SQLite.lastInsertRowId conn - ) - -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) - case mbIncome of - Just income -> - if _income_userId income == incomeUserId - then do - now <- getCurrentTime - SQLite.execute - conn - "UPDATE income SET edited_at = ?, date = ?, amount = ? WHERE id = ?" - (now, incomeDate, incomeAmount, incomeId) - return True - else - return False - Nothing -> - return False - ) - -deleteOwn :: User -> IncomeId -> Query Bool -deleteOwn user incomeId = - Query (\conn -> do - mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId) - case mbIncome of - Just income -> - if _income_userId income == _user_id user - then do - now <- getCurrentTime - SQLite.execute conn "UPDATE income SET deleted_at = ? WHERE id = ?" (now, incomeId) - return True - else - return False - Nothing -> - return False - ) 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/Payment.hs b/server/src/Model/Payment.hs deleted file mode 100644 index 5b29409..0000000 --- a/server/src/Model/Payment.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.Payment - ( Payment(..) - , find - , listActive - , listPunctual - , listActiveMonthlyOrderedByName - , create - , createMany - , editOwn - , deleteOwn - ) where - -import Data.Maybe (listToMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Calendar (Day) -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (FromRow (fromRow), Only (Only), - ToRow) -import qualified Database.SQLite.Simple as SQLite -import Database.SQLite.Simple.ToField (ToField (toField)) -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) - -instance Resource Payment where - resourceCreatedAt = _payment_createdAt - resourceEditedAt = _payment_editedAt - resourceDeletedAt = _payment_deletedAt - -instance FromRow Payment where - fromRow = Payment <$> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field - -instance ToRow Payment where - toRow p = - [ toField (_payment_user p) - , toField (_payment_name p) - , toField (_payment_cost p) - , toField (_payment_date p) - , toField (_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) - ) - -listActive :: Query [Payment] -listActive = - Query (\conn -> - 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)) - -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)) - -create :: UserId -> Text -> Int -> Day -> Frequency -> Query PaymentId -create userId paymentName paymentCost paymentDate paymentFrequency = - Query (\conn -> do - now <- getCurrentTime - SQLite.execute - conn - (SQLite.Query $ T.intercalate " " - [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" - , "VALUES (?, ?, ?, ?, ?, ?)" - ]) - (userId, paymentName, paymentCost, paymentDate, paymentFrequency, now) - SQLite.lastInsertRowId conn - ) - -createMany :: [Payment] -> Query () -createMany payments = - Query (\conn -> - SQLite.executeMany - conn - (SQLite.Query $ T.intercalate "" - [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" - , "VALUES (?, ?, ?, ?, ?, ?)" - ]) - payments - ) - -editOwn :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool -editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency = - Query (\conn -> do - mbPayment <- listToMaybe <$> - SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) - case mbPayment of - Just payment -> - if _payment_user payment == userId - then do - now <- getCurrentTime - SQLite.execute - conn - (SQLite.Query $ T.intercalate " " - [ "UPDATE payment" - , "SET edited_at = ?," - , " name = ?," - , " cost = ?," - , " date = ?," - , " frequency = ?" - , "WHERE id = ?" - ]) - (now, paymentName, paymentCost, paymentDate, paymentFrequency, paymentId) - return True - else - return False - Nothing -> - return False - ) - -deleteOwn :: UserId -> PaymentId -> Query Bool -deleteOwn userId paymentId = - Query (\conn -> do - mbPayment <- listToMaybe <$> - SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) - case mbPayment of - Just payment -> - if _payment_user payment == userId - then do - now <- getCurrentTime - SQLite.execute - conn - "UPDATE payment SET deleted_at = ? WHERE id = ?" - (now, paymentId) - return True - else - return False - Nothing -> - return False - ) diff --git a/server/src/Model/PaymentCategory.hs b/server/src/Model/PaymentCategory.hs deleted file mode 100644 index c60c1a2..0000000 --- a/server/src/Model/PaymentCategory.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Model.PaymentCategory - ( list - , listByCategory - , save - ) where - -import Data.Maybe (isJust, listToMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Clock (getCurrentTime) -import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) -import qualified Database.SQLite.Simple as SQLite - -import Common.Model (CategoryId, PaymentCategory (..)) -import qualified Common.Util.Text as T - -import Model.Query (Query (Query)) - -instance FromRow PaymentCategory where - fromRow = PaymentCategory <$> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field <*> - SQLite.field - -list :: Query [PaymentCategory] -list = Query (\conn -> 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) - ) - -save :: Text -> CategoryId -> Query () -save newName categoryId = - Query (\conn -> do - now <- getCurrentTime - mbPaymentCategory <- listToMaybe <$> - (SQLite.query - conn - "SELECT * FROM payment_category WHERE name = ?" - (Only (formatPaymentName newName)) :: IO [PaymentCategory]) - if isJust mbPaymentCategory - 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) - ) - where - formatPaymentName :: Text -> Text - formatPaymentName = T.unaccent . T.toLower 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/Persistence/Category.hs b/server/src/Persistence/Category.hs new file mode 100644 index 0000000..2afe5db --- /dev/null +++ b/server/src/Persistence/Category.hs @@ -0,0 +1,79 @@ +module Persistence.Category + ( list + , create + , edit + , delete + ) where + +import Data.Maybe (isJust, 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 (Category (..), CategoryId) + +import Model.Query (Query (Query)) + +newtype Row = Row Category + +instance FromRow Row where + fromRow = Row <$> (Category <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field) + +list :: Query [Category] +list = + Query (\conn -> + map (\(Row c) -> c) <$> + SQLite.query_ conn "SELECT * FROM category WHERE deleted_at IS NULL" + ) + +create :: Text -> Text -> Query CategoryId +create categoryName categoryColor = + Query (\conn -> do + now <- getCurrentTime + SQLite.execute + conn + "INSERT INTO category (name, color, created_at) VALUES (?, ?, ?)" + (categoryName, categoryColor, now) + SQLite.lastInsertRowId conn + ) + +edit :: CategoryId -> Text -> Text -> Query Bool +edit categoryId categoryName categoryColor = + Query (\conn -> do + mbCategory <- fmap (\(Row c) -> c) . listToMaybe <$> + (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId)) + if isJust mbCategory + then do + now <- getCurrentTime + SQLite.execute + conn + "UPDATE category SET edited_at = ?, name = ?, color = ? WHERE id = ?" + (now, categoryName, categoryColor, categoryId) + return True + else + return False + ) + +delete :: CategoryId -> Query Bool +delete categoryId = + Query (\conn -> do + mbCategory <- fmap (\(Row c) -> c) . listToMaybe <$> + (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId)) + if isJust mbCategory + then do + now <- getCurrentTime + SQLite.execute + conn + "UPDATE category SET deleted_at = ? WHERE id = ?" (now, categoryId) + return True + else + return False + ) diff --git a/server/src/Persistence/Frequency.hs b/server/src/Persistence/Frequency.hs new file mode 100644 index 0000000..edaa844 --- /dev/null +++ b/server/src/Persistence/Frequency.hs @@ -0,0 +1,23 @@ +module Persistence.Frequency + ( FrequencyField(..) + ) where + +import qualified Data.Text as T +import Database.SQLite.Simple (SQLData (SQLText)) +import Database.SQLite.Simple.FromField (FromField (fromField), + fieldData) +import Database.SQLite.Simple.Ok (Ok (Errors, Ok)) +import Database.SQLite.Simple.ToField (ToField (toField)) + +import Common.Model (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 FrequencyField where + toField (FrequencyField f) = SQLText . T.pack . show $ f diff --git a/server/src/Persistence/Income.hs b/server/src/Persistence/Income.hs new file mode 100644 index 0000000..a863f85 --- /dev/null +++ b/server/src/Persistence/Income.hs @@ -0,0 +1,88 @@ +module Persistence.Income + ( list + , create + , editOwn + , deleteOwn + ) where + +import Data.Maybe (listToMaybe) +import Data.Time.Calendar (Day) +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 (Income (..), IncomeId, User (..), + UserId) + +import Model.Query (Query (Query)) + +newtype Row = Row Income + +instance FromRow Row where + fromRow = Row <$> (Income <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field) + +list :: Query [Income] +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 = + Query (\conn -> do + now <- getCurrentTime + SQLite.execute + conn + "INSERT INTO income (user_id, date, amount, created_at) VALUES (?, ?, ?, ?)" + (incomeUserId, incomeDate, incomeAmount, now) + SQLite.lastInsertRowId conn + ) + +editOwn :: UserId -> IncomeId -> Day -> Int -> Query Bool +editOwn incomeUserId incomeId incomeDate incomeAmount = + Query (\conn -> do + 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 + then do + now <- getCurrentTime + SQLite.execute + conn + "UPDATE income SET edited_at = ?, date = ?, amount = ? WHERE id = ?" + (now, incomeDate, incomeAmount, incomeId) + return True + else + return False + Nothing -> + return False + ) + +deleteOwn :: User -> IncomeId -> Query Bool +deleteOwn user incomeId = + Query (\conn -> do + 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 + then do + now <- getCurrentTime + SQLite.execute conn "UPDATE income SET deleted_at = ? WHERE id = ?" (now, incomeId) + return True + else + return False + Nothing -> + return False + ) 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/Persistence/Payment.hs b/server/src/Persistence/Payment.hs new file mode 100644 index 0000000..32600d7 --- /dev/null +++ b/server/src/Persistence/Payment.hs @@ -0,0 +1,169 @@ +module Persistence.Payment + ( Payment(..) + , find + , listActive + , listPunctual + , listActiveMonthlyOrderedByName + , create + , createMany + , editOwn + , deleteOwn + ) where + +import Data.Maybe (listToMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Calendar (Day) +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (FromRow (fromRow), Only (Only), + ToRow) +import qualified Database.SQLite.Simple as SQLite +import Database.SQLite.Simple.ToField (ToField (toField)) +import Prelude hiding (id) + +import Common.Model (Frequency (..), Payment (..), + PaymentId, UserId) + +import Model.Query (Query (Query)) +import Persistence.Frequency (FrequencyField (..)) + +newtype Row = Row Payment + +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) + +newtype InsertRow = InsertRow Payment + +instance ToRow InsertRow where + toRow (InsertRow p) = + [ toField (_payment_user p) + , toField (_payment_name p) + , toField (_payment_cost p) + , toField (_payment_date p) + , toField (FrequencyField (_payment_frequency p)) + , toField (_payment_createdAt p) + ] + +find :: PaymentId -> Query (Maybe Payment) +find 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 -> do + map (\(Row p) -> p) <$> + SQLite.query_ conn "SELECT * FROM payment WHERE deleted_at IS NULL" + ) + +listPunctual :: Query [Payment] +listPunctual = + 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 -> 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 = + Query (\conn -> do + now <- getCurrentTime + SQLite.execute + conn + (SQLite.Query $ T.intercalate " " + [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" + , "VALUES (?, ?, ?, ?, ?, ?)" + ]) + (userId, paymentName, paymentCost, paymentDate, FrequencyField paymentFrequency, now) + SQLite.lastInsertRowId conn + ) + +createMany :: [Payment] -> Query () +createMany payments = + Query (\conn -> + SQLite.executeMany + conn + (SQLite.Query $ T.intercalate "" + [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)" + , "VALUES (?, ?, ?, ?, ?, ?)" + ]) + (map InsertRow payments) + ) + +editOwn :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool +editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency = + Query (\conn -> do + mbPayment <- fmap (\(Row p) -> p) . listToMaybe <$> + SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) + case mbPayment of + Just payment -> + if _payment_user payment == userId + then do + now <- getCurrentTime + SQLite.execute + conn + (SQLite.Query $ T.intercalate " " + [ "UPDATE payment" + , "SET edited_at = ?," + , " name = ?," + , " cost = ?," + , " date = ?," + , " frequency = ?" + , "WHERE id = ?" + ]) + (now, paymentName, paymentCost, paymentDate, FrequencyField paymentFrequency, paymentId) + return True + else + return False + Nothing -> + return False + ) + +deleteOwn :: UserId -> PaymentId -> Query Bool +deleteOwn userId paymentId = + Query (\conn -> do + mbPayment <- listToMaybe <$> + SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId) + case mbPayment of + Just (Row payment) -> + if _payment_user payment == userId + then do + now <- getCurrentTime + SQLite.execute + conn + "UPDATE payment SET deleted_at = ? WHERE id = ?" + (now, paymentId) + return True + else + return False + Nothing -> + return False + ) diff --git a/server/src/Persistence/PaymentCategory.hs b/server/src/Persistence/PaymentCategory.hs new file mode 100644 index 0000000..1e377b1 --- /dev/null +++ b/server/src/Persistence/PaymentCategory.hs @@ -0,0 +1,66 @@ +module Persistence.PaymentCategory + ( list + , listByCategory + , save + ) where + +import Data.Maybe (isJust, listToMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (getCurrentTime) +import Database.SQLite.Simple (FromRow (fromRow), Only (Only)) +import qualified Database.SQLite.Simple as SQLite + +import Common.Model (CategoryId, PaymentCategory (..)) +import qualified Common.Util.Text as T + +import Model.Query (Query (Query)) + +newtype Row = Row PaymentCategory + +instance FromRow Row where + fromRow = Row <$> (PaymentCategory <$> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field <*> + SQLite.field) + +list :: Query [PaymentCategory] +list = + Query (\conn -> do + map (\(Row pc) -> pc) <$> + SQLite.query_ conn "SELECT * from payment_category" + ) + +listByCategory :: CategoryId -> Query [PaymentCategory] +listByCategory 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 + hasPaymentCategory <- isJust <$> 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) + ) + where + formatPaymentName :: Text -> Text + formatPaymentName = T.unaccent . T.toLower 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 = -- cgit v1.2.3