From 27e11b20b06f2f2dbfb56c0998a63169b4b8abc4 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 8 Nov 2017 23:47:26 +0100 Subject: Use a better project structure --- server/src/Controller/Category.hs | 53 ++++++++++++++++++++++++ server/src/Controller/Income.hs | 48 ++++++++++++++++++++++ server/src/Controller/Index.hs | 86 +++++++++++++++++++++++++++++++++++++++ server/src/Controller/Payment.hs | 58 ++++++++++++++++++++++++++ server/src/Controller/SignIn.hs | 47 +++++++++++++++++++++ 5 files changed, 292 insertions(+) create mode 100644 server/src/Controller/Category.hs create mode 100644 server/src/Controller/Income.hs create mode 100644 server/src/Controller/Index.hs create mode 100644 server/src/Controller/Payment.hs create mode 100644 server/src/Controller/SignIn.hs (limited to 'server/src/Controller') diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs new file mode 100644 index 0000000..d6ed2f2 --- /dev/null +++ b/server/src/Controller/Category.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Controller.Category + ( create + , edit + , delete + ) where + +import Control.Monad.IO.Class (liftIO) +import Network.HTTP.Types.Status (ok200, badRequest400) +import qualified Data.Text.Lazy as TL +import Web.Scotty hiding (delete) + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (CategoryId, CreateCategory(..), EditCategory(..)) + +import Json (jsonId) +import qualified Model.Category as Category +import qualified Model.PaymentCategory as PaymentCategory +import qualified Model.Query as Query +import qualified Secure + +create :: CreateCategory -> ActionM () +create (CreateCategory name color) = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ Category.create name color) >>= jsonId + ) + +edit :: EditCategory -> ActionM () +edit (EditCategory categoryId name color) = + Secure.loggedAction (\_ -> do + updated <- liftIO . Query.run $ Category.edit categoryId name color + if updated + then status ok200 + else status badRequest400 + ) + +delete :: CategoryId -> ActionM () +delete categoryId = + Secure.loggedAction (\_ -> do + deleted <- liftIO . Query.run $ do + paymentCategories <- PaymentCategory.listByCategory categoryId + if null paymentCategories + then Category.delete categoryId + else return False + if deleted + then + status ok200 + else do + status badRequest400 + text . TL.fromStrict $ Message.get Key.Category_NotDeleted + ) diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs new file mode 100644 index 0000000..148b713 --- /dev/null +++ b/server/src/Controller/Income.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Controller.Income + ( create + , editOwn + , deleteOwn + ) where + +import Control.Monad.IO.Class (liftIO) +import Network.HTTP.Types.Status (ok200, badRequest400) +import qualified Data.Text.Lazy as TL +import Web.Scotty + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (CreateIncome(..), EditIncome(..), IncomeId, User(..)) + +import Json (jsonId) +import qualified Model.Income as Income +import qualified Model.Query as Query +import qualified Secure + +create :: CreateIncome -> ActionM () +create (CreateIncome date amount) = + Secure.loggedAction (\user -> + (liftIO . Query.run $ Income.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 + if updated + then status ok200 + else status badRequest400 + ) + +deleteOwn :: IncomeId -> ActionM () +deleteOwn incomeId = + Secure.loggedAction (\user -> do + deleted <- liftIO . Query.run $ Income.deleteOwn user incomeId + if deleted + then + status ok200 + else do + status badRequest400 + text . TL.fromStrict $ Message.get Key.Income_NotDeleted + ) diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs new file mode 100644 index 0000000..8473c5c --- /dev/null +++ b/server/src/Controller/Index.hs @@ -0,0 +1,86 @@ +module Controller.Index + ( get + , signOut + ) where + +import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import Data.Time.Clock (getCurrentTime, diffUTCTime) +import Network.HTTP.Types.Status (ok200) +import Prelude hiding (error) +import Web.Scotty hiding (get) + +import qualified Common.Message as Message +import Common.Message.Key (Key) +import qualified Common.Message.Key as Key +import Common.Model (InitResult(..), User(..)) + +import Conf (Conf(..)) +import Model.Init (getInit) +import qualified LoginSession +import qualified Model.Query as Query +import qualified Model.SignIn as SignIn +import qualified Model.User as User +import Secure (getUserFromToken) +import View.Page (page) + +get :: Conf -> Maybe Text -> ActionM () +get conf mbToken = do + initResult <- case mbToken of + Just token -> do + userOrError <- validateSignIn conf token + case userOrError of + Left errorKey -> + return . InitEmpty . Left . Message.get $ errorKey + Right user -> + liftIO . Query.run . fmap InitSuccess $ getInit user conf + Nothing -> do + mbLoggedUser <- getLoggedUser + case mbLoggedUser of + Nothing -> + return . InitEmpty . Right $ Nothing + Just user -> + liftIO . Query.run . fmap InitSuccess $ getInit user conf + html $ page initResult + +validateSignIn :: Conf -> Text -> ActionM (Either Key User) +validateSignIn conf textToken = do + mbLoggedUser <- getLoggedUser + case mbLoggedUser of + Just loggedUser -> + return . Right $ loggedUser + Nothing -> do + mbSignIn <- liftIO . Query.run $ SignIn.getSignIn textToken + now <- liftIO getCurrentTime + case mbSignIn of + Nothing -> + return . Left $ Key.SignIn_LinkInvalid + Just signIn -> + if SignIn.isUsed signIn + then + return . Left $ Key.SignIn_LinkUsed + else + let diffTime = now `diffUTCTime` (SignIn.creation signIn) + in if diffTime > signInExpiration conf + then + return . Left $ Key.SignIn_LinkExpired + else do + LoginSession.put conf (SignIn.token signIn) + mbUser <- liftIO . Query.run $ do + SignIn.signInTokenToUsed . SignIn.id $ signIn + User.get . SignIn.email $ signIn + return $ case mbUser of + Nothing -> Left Key.Secure_Unauthorized + Just user -> Right user + +getLoggedUser :: ActionM (Maybe User) +getLoggedUser = do + mbToken <- LoginSession.get + case mbToken of + Nothing -> + return Nothing + Just token -> do + liftIO . Query.run . getUserFromToken $ token + +signOut :: Conf -> ActionM () +signOut conf = LoginSession.delete conf >> status ok200 diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs new file mode 100644 index 0000000..dc10311 --- /dev/null +++ b/server/src/Controller/Payment.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Controller.Payment + ( list + , create + , editOwn + , deleteOwn + ) where + +import Control.Monad.IO.Class (liftIO) +import Network.HTTP.Types.Status (ok200, badRequest400) +import Web.Scotty + +import Common.Model (PaymentId, User(..), CreatePayment(..), EditPayment(..)) + +import Json (jsonId) +import qualified Model.Payment as Payment +import qualified Model.PaymentCategory as PaymentCategory +import qualified Model.Query as Query +import qualified Secure + +list :: ActionM () +list = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ Payment.list) >>= 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 + ) + +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 + _ <- if edited + then PaymentCategory.save name category >> return () + else return () + return edited + if updated + then status ok200 + else status badRequest400 + ) + +deleteOwn :: PaymentId -> ActionM () +deleteOwn paymentId = + Secure.loggedAction (\user -> do + deleted <- liftIO . Query.run $ Payment.deleteOwn (_user_id user) paymentId + if deleted + then status ok200 + else status badRequest400 + ) diff --git a/server/src/Controller/SignIn.hs b/server/src/Controller/SignIn.hs new file mode 100644 index 0000000..0086fa5 --- /dev/null +++ b/server/src/Controller/SignIn.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Controller.SignIn + ( signIn + ) where + +import Control.Monad.IO.Class (liftIO) +import Network.HTTP.Types.Status (ok200, badRequest400) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as TL +import Web.Scotty + +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (SignIn(..)) + +import Conf (Conf) +import qualified Conf +import qualified Model.Query as Query +import qualified Model.SignIn as SignIn +import qualified Model.User as User +import qualified SendMail +import qualified Text.Email.Validate as Email +import qualified View.Mail.SignIn as SignIn + +signIn :: Conf -> SignIn -> ActionM () +signIn conf (SignIn email) = + if Email.isValid (TE.encodeUtf8 email) + then do + maybeUser <- liftIO . Query.run $ User.get email + case maybeUser of + Just user -> do + token <- liftIO . Query.run $ SignIn.createSignInToken email + let url = T.concat [ + if Conf.https conf then "https://" else "http://", + Conf.hostname conf, + "?signInToken=", + token + ] + maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [email] + case maybeSentMail of + Right _ -> textKey ok200 Key.SignIn_EmailSent + Left _ -> textKey badRequest400 Key.SignIn_EmailSendFail + Nothing -> textKey badRequest400 Key.Secure_Unauthorized + else textKey badRequest400 Key.SignIn_EmailInvalid + where textKey st key = status st >> (text . TL.fromStrict $ Message.get key) -- cgit v1.2.3 From 5a63f7be9375e3ab888e4232dd7ef72c2f1ffae1 Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 13 Nov 2017 23:56:40 +0100 Subject: Setup stylish-haskell --- server/src/Controller/Category.hs | 23 ++++++++++++----------- server/src/Controller/Income.hs | 21 +++++++++++---------- server/src/Controller/Index.hs | 36 ++++++++++++++++++------------------ server/src/Controller/Payment.hs | 22 ++++++++++++---------- server/src/Controller/SignIn.hs | 32 ++++++++++++++++---------------- 5 files changed, 69 insertions(+), 65 deletions(-) (limited to 'server/src/Controller') diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs index d6ed2f2..a646496 100644 --- a/server/src/Controller/Category.hs +++ b/server/src/Controller/Category.hs @@ -6,19 +6,20 @@ module Controller.Category , delete ) where -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import qualified Data.Text.Lazy as TL -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 qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (CategoryId, CreateCategory(..), EditCategory(..)) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (CategoryId, CreateCategory (..), + EditCategory (..)) -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.Category as Category +import qualified Model.PaymentCategory as PaymentCategory +import qualified Model.Query as Query import qualified Secure create :: CreateCategory -> ActionM () diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 148b713..c42f6a7 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -6,18 +6,19 @@ module Controller.Income , deleteOwn ) where -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import qualified Data.Text.Lazy as TL -import Web.Scotty +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text.Lazy as TL +import Network.HTTP.Types.Status (badRequest400, ok200) +import Web.Scotty -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (CreateIncome(..), EditIncome(..), IncomeId, User(..)) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (CreateIncome (..), EditIncome (..), + IncomeId, User (..)) -import Json (jsonId) -import qualified Model.Income as Income -import qualified Model.Query as Query +import Json (jsonId) +import qualified Model.Income as Income +import qualified Model.Query as Query import qualified Secure create :: CreateIncome -> ActionM () diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index 8473c5c..bf4859d 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -3,26 +3,26 @@ module Controller.Index , signOut ) where -import Control.Monad.IO.Class (liftIO) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime, diffUTCTime) -import Network.HTTP.Types.Status (ok200) -import Prelude hiding (error) -import Web.Scotty hiding (get) +import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import Data.Time.Clock (diffUTCTime, getCurrentTime) +import Network.HTTP.Types.Status (ok200) +import Prelude hiding (error) +import Web.Scotty hiding (get) -import qualified Common.Message as Message -import Common.Message.Key (Key) -import qualified Common.Message.Key as Key -import Common.Model (InitResult(..), User(..)) +import qualified Common.Message as Message +import Common.Message.Key (Key) +import qualified Common.Message.Key as Key +import Common.Model (InitResult (..), User (..)) -import Conf (Conf(..)) -import Model.Init (getInit) +import Conf (Conf (..)) import qualified LoginSession -import qualified Model.Query as Query -import qualified Model.SignIn as SignIn -import qualified Model.User as User -import Secure (getUserFromToken) -import View.Page (page) +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 View.Page (page) get :: Conf -> Maybe Text -> ActionM () get conf mbToken = do @@ -70,7 +70,7 @@ validateSignIn conf textToken = do SignIn.signInTokenToUsed . SignIn.id $ signIn User.get . SignIn.email $ signIn return $ case mbUser of - Nothing -> Left Key.Secure_Unauthorized + Nothing -> Left Key.Secure_Unauthorized Just user -> Right user getLoggedUser :: ActionM (Maybe User) diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index dc10311..e4104eb 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -7,16 +7,18 @@ module Controller.Payment , deleteOwn ) where -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import Web.Scotty - -import Common.Model (PaymentId, User(..), CreatePayment(..), EditPayment(..)) - -import Json (jsonId) -import qualified Model.Payment as Payment -import qualified Model.PaymentCategory as PaymentCategory -import qualified Model.Query as Query +import Control.Monad.IO.Class (liftIO) +import Network.HTTP.Types.Status (badRequest400, ok200) +import Web.Scotty + +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 Secure list :: ActionM () diff --git a/server/src/Controller/SignIn.hs b/server/src/Controller/SignIn.hs index 0086fa5..5552781 100644 --- a/server/src/Controller/SignIn.hs +++ b/server/src/Controller/SignIn.hs @@ -4,25 +4,25 @@ module Controller.SignIn ( signIn ) where -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL -import Web.Scotty +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as TL +import Network.HTTP.Types.Status (badRequest400, ok200) +import Web.Scotty -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (SignIn(..)) +import qualified Common.Message as Message +import qualified Common.Message.Key as Key +import Common.Model (SignIn (..)) -import Conf (Conf) +import Conf (Conf) import qualified Conf -import qualified Model.Query as Query -import qualified Model.SignIn as SignIn -import qualified Model.User as User +import qualified Model.Query as Query +import qualified Model.SignIn as SignIn +import qualified Model.User as User import qualified SendMail -import qualified Text.Email.Validate as Email -import qualified View.Mail.SignIn as SignIn +import qualified Text.Email.Validate as Email +import qualified View.Mail.SignIn as SignIn signIn :: Conf -> SignIn -> ActionM () signIn conf (SignIn email) = @@ -41,7 +41,7 @@ signIn conf (SignIn email) = maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [email] case maybeSentMail of Right _ -> textKey ok200 Key.SignIn_EmailSent - Left _ -> textKey badRequest400 Key.SignIn_EmailSendFail + Left _ -> textKey badRequest400 Key.SignIn_EmailSendFail Nothing -> textKey badRequest400 Key.Secure_Unauthorized else textKey badRequest400 Key.SignIn_EmailInvalid where textKey st key = status st >> (text . TL.fromStrict $ Message.get key) -- cgit v1.2.3 From 7194cddb28656c721342c2ef604f9f9fb0692960 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 19 Nov 2017 00:20:25 +0100 Subject: Show payment count and partition - Also fixes exceedingPayer in back by using only punctual payments --- server/src/Controller/Category.hs | 7 ++----- server/src/Controller/Income.hs | 7 ++----- server/src/Controller/Index.hs | 15 +++++++-------- server/src/Controller/Payment.hs | 2 -- server/src/Controller/SignIn.hs | 15 ++++++--------- 5 files changed, 17 insertions(+), 29 deletions(-) (limited to 'server/src/Controller') diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs index a646496..5565b43 100644 --- a/server/src/Controller/Category.hs +++ b/server/src/Controller/Category.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Controller.Category ( create , edit @@ -11,10 +9,9 @@ import qualified Data.Text.Lazy as TL import Network.HTTP.Types.Status (badRequest400, ok200) import Web.Scotty hiding (delete) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key import Common.Model (CategoryId, CreateCategory (..), EditCategory (..)) +import qualified Common.Msg as Msg import Json (jsonId) import qualified Model.Category as Category @@ -50,5 +47,5 @@ delete categoryId = status ok200 else do status badRequest400 - text . TL.fromStrict $ Message.get Key.Category_NotDeleted + text . TL.fromStrict $ Msg.get Msg.Category_NotDeleted ) diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index c42f6a7..19f0cfc 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Controller.Income ( create , editOwn @@ -11,10 +9,9 @@ import qualified Data.Text.Lazy as TL import Network.HTTP.Types.Status (badRequest400, ok200) import Web.Scotty -import qualified Common.Message as Message -import qualified Common.Message.Key as Key import Common.Model (CreateIncome (..), EditIncome (..), IncomeId, User (..)) +import qualified Common.Msg as Msg import Json (jsonId) import qualified Model.Income as Income @@ -45,5 +42,5 @@ deleteOwn incomeId = status ok200 else do status badRequest400 - text . TL.fromStrict $ Message.get Key.Income_NotDeleted + text . TL.fromStrict $ Msg.get Msg.Income_NotDeleted ) diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index bf4859d..f05ce6f 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -10,10 +10,9 @@ import Network.HTTP.Types.Status (ok200) import Prelude hiding (error) import Web.Scotty hiding (get) -import qualified Common.Message as Message -import Common.Message.Key (Key) -import qualified Common.Message.Key as Key import Common.Model (InitResult (..), User (..)) +import Common.Msg (Key) +import qualified Common.Msg as Msg import Conf (Conf (..)) import qualified LoginSession @@ -31,7 +30,7 @@ get conf mbToken = do userOrError <- validateSignIn conf token case userOrError of Left errorKey -> - return . InitEmpty . Left . Message.get $ errorKey + return . InitEmpty . Left . Msg.get $ errorKey Right user -> liftIO . Query.run . fmap InitSuccess $ getInit user conf Nothing -> do @@ -54,23 +53,23 @@ validateSignIn conf textToken = do now <- liftIO getCurrentTime case mbSignIn of Nothing -> - return . Left $ Key.SignIn_LinkInvalid + return . Left $ Msg.SignIn_LinkInvalid Just signIn -> if SignIn.isUsed signIn then - return . Left $ Key.SignIn_LinkUsed + return . Left $ Msg.SignIn_LinkUsed else let diffTime = now `diffUTCTime` (SignIn.creation signIn) in if diffTime > signInExpiration conf then - return . Left $ Key.SignIn_LinkExpired + return . Left $ Msg.SignIn_LinkExpired else do LoginSession.put conf (SignIn.token signIn) mbUser <- liftIO . Query.run $ do SignIn.signInTokenToUsed . SignIn.id $ signIn User.get . SignIn.email $ signIn return $ case mbUser of - Nothing -> Left Key.Secure_Unauthorized + Nothing -> Left Msg.Secure_Unauthorized Just user -> Right user getLoggedUser :: ActionM (Maybe User) diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index e4104eb..c6c874a 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Controller.Payment ( list , create diff --git a/server/src/Controller/SignIn.hs b/server/src/Controller/SignIn.hs index 5552781..cf92c9f 100644 --- a/server/src/Controller/SignIn.hs +++ b/server/src/Controller/SignIn.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Controller.SignIn ( signIn ) where @@ -11,9 +9,8 @@ import qualified Data.Text.Lazy as TL import Network.HTTP.Types.Status (badRequest400, ok200) import Web.Scotty -import qualified Common.Message as Message -import qualified Common.Message.Key as Key import Common.Model (SignIn (..)) +import qualified Common.Msg as Msg import Conf (Conf) import qualified Conf @@ -40,8 +37,8 @@ signIn conf (SignIn email) = ] maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [email] case maybeSentMail of - Right _ -> textKey ok200 Key.SignIn_EmailSent - Left _ -> textKey badRequest400 Key.SignIn_EmailSendFail - Nothing -> textKey badRequest400 Key.Secure_Unauthorized - else textKey badRequest400 Key.SignIn_EmailInvalid - where textKey st key = status st >> (text . TL.fromStrict $ Message.get key) + Right _ -> textKey ok200 Msg.SignIn_EmailSent + Left _ -> textKey badRequest400 Msg.SignIn_EmailSendFail + Nothing -> textKey badRequest400 Msg.Secure_Unauthorized + else textKey badRequest400 Msg.SignIn_EmailInvalid + where textKey st key = status st >> (text . TL.fromStrict $ Msg.get key) -- cgit v1.2.3 From a4acc2e84158fa822f88a1d0bdddb470708b5809 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 3 Jan 2018 17:31:20 +0100 Subject: Modify weelky report and payment search interface - Add payment balance in weekly report - Show a message and hide pages when the search results in no results - Go to page 1 when the search is updated / erased --- server/src/Controller/Index.hs | 77 ++++++++++++++++++++++++++++------------ server/src/Controller/Payment.hs | 2 +- server/src/Controller/SignIn.hs | 44 ----------------------- 3 files changed, 56 insertions(+), 67 deletions(-) delete mode 100644 server/src/Controller/SignIn.hs (limited to 'server/src/Controller') diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index f05ce6f..9a3e2b7 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -1,16 +1,23 @@ module Controller.Index ( get + , askSignIn + , trySignIn , signOut ) where import Control.Monad.IO.Class (liftIO) import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as TL import Data.Time.Clock (diffUTCTime, getCurrentTime) -import Network.HTTP.Types.Status (ok200) +import Network.HTTP.Types.Status (badRequest400, ok200) import Prelude hiding (error) -import Web.Scotty hiding (get) +import Web.Scotty (ActionM) +import qualified Web.Scotty as S -import Common.Model (InitResult (..), User (..)) +import Common.Model (InitResult (..), SignIn (..), + User (..)) import Common.Msg (Key) import qualified Common.Msg as Msg @@ -21,26 +28,52 @@ import qualified Model.Query as Query import qualified Model.SignIn as SignIn import qualified Model.User as User import Secure (getUserFromToken) +import qualified SendMail +import qualified Text.Email.Validate as Email +import qualified View.Mail.SignIn as SignIn import View.Page (page) -get :: Conf -> Maybe Text -> ActionM () -get conf mbToken = do - initResult <- case mbToken of - Just token -> do - userOrError <- validateSignIn conf token - case userOrError of - Left errorKey -> - return . InitEmpty . Left . Msg.get $ errorKey - Right user -> - liftIO . Query.run . fmap InitSuccess $ getInit user conf - Nothing -> do - mbLoggedUser <- getLoggedUser - case mbLoggedUser of - Nothing -> - return . InitEmpty . Right $ Nothing - Just user -> - liftIO . Query.run . fmap InitSuccess $ getInit user conf - html $ page initResult +get :: Conf -> ActionM () +get conf = do + initResult <- do + mbLoggedUser <- getLoggedUser + case mbLoggedUser of + Nothing -> + return . InitEmpty . Right $ Nothing + Just user -> + liftIO . Query.run . fmap InitSuccess $ 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 + case maybeUser of + Just user -> do + token <- liftIO . Query.run $ SignIn.createSignInToken email + let url = T.concat [ + if Conf.https conf then "https://" else "http://", + Conf.hostname conf, + "/signIn/", + token + ] + maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email] + case maybeSentMail of + Right _ -> textKey ok200 Msg.SignIn_EmailSent + Left _ -> textKey badRequest400 Msg.SignIn_EmailSendFail + Nothing -> textKey badRequest400 Msg.Secure_Unauthorized + else textKey badRequest400 Msg.SignIn_EmailInvalid + where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key) + +trySignIn :: Conf -> Text -> ActionM () +trySignIn conf token = do + userOrError <- validateSignIn conf token + case userOrError of + Left errorKey -> + S.html $ page (InitEmpty . Left . Msg.get $ errorKey) + Right _ -> + S.redirect "/" validateSignIn :: Conf -> Text -> ActionM (Either Key User) validateSignIn conf textToken = do @@ -82,4 +115,4 @@ getLoggedUser = do liftIO . Query.run . getUserFromToken $ token signOut :: Conf -> ActionM () -signOut conf = LoginSession.delete conf >> status ok200 +signOut conf = LoginSession.delete conf >> S.status ok200 diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index c6c874a..f2af6c9 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -22,7 +22,7 @@ import qualified Secure list :: ActionM () list = Secure.loggedAction (\_ -> - (liftIO . Query.run $ Payment.list) >>= json + (liftIO . Query.run $ Payment.listActive) >>= json ) create :: CreatePayment -> ActionM () diff --git a/server/src/Controller/SignIn.hs b/server/src/Controller/SignIn.hs deleted file mode 100644 index cf92c9f..0000000 --- a/server/src/Controller/SignIn.hs +++ /dev/null @@ -1,44 +0,0 @@ -module Controller.SignIn - ( signIn - ) where - -import Control.Monad.IO.Class (liftIO) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL -import Network.HTTP.Types.Status (badRequest400, ok200) -import Web.Scotty - -import Common.Model (SignIn (..)) -import qualified Common.Msg as Msg - -import Conf (Conf) -import qualified Conf -import qualified Model.Query as Query -import qualified Model.SignIn as SignIn -import qualified Model.User as User -import qualified SendMail -import qualified Text.Email.Validate as Email -import qualified View.Mail.SignIn as SignIn - -signIn :: Conf -> SignIn -> ActionM () -signIn conf (SignIn email) = - if Email.isValid (TE.encodeUtf8 email) - then do - maybeUser <- liftIO . Query.run $ User.get email - case maybeUser of - Just user -> do - token <- liftIO . Query.run $ SignIn.createSignInToken email - let url = T.concat [ - if Conf.https conf then "https://" else "http://", - Conf.hostname conf, - "?signInToken=", - token - ] - maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [email] - case maybeSentMail of - Right _ -> textKey ok200 Msg.SignIn_EmailSent - Left _ -> textKey badRequest400 Msg.SignIn_EmailSendFail - Nothing -> textKey badRequest400 Msg.Secure_Unauthorized - else textKey badRequest400 Msg.SignIn_EmailInvalid - where textKey st key = status st >> (text . TL.fromStrict $ Msg.get key) -- cgit v1.2.3 From 33b85b7f12798f5762d940ed5c30f775cdd7b751 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 28 Jan 2018 12:13:09 +0100 Subject: WIP --- server/src/Controller/Category.hs | 30 ++++++++++++++--------------- server/src/Controller/Income.hs | 8 ++++---- server/src/Controller/Index.hs | 18 +++++++++--------- server/src/Controller/Payment.hs | 40 +++++++++++++++++++-------------------- 4 files changed, 48 insertions(+), 48 deletions(-) (limited to 'server/src/Controller') 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 ) -- cgit v1.2.3 From 40b4994797a797b1fa86cafda789a5c488730c6d Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 28 Oct 2018 17:57:58 +0100 Subject: Delete payment --- server/src/Controller/Payment.hs | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) (limited to 'server/src/Controller') diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index e1936f0..4edbf6a 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -18,6 +18,7 @@ import qualified Model.Query as Query import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.PaymentCategory as PaymentCategoryPersistence import qualified Secure +import qualified Validation.CreatePayment as CreatePaymentValidation list :: ActionM () list = @@ -26,12 +27,18 @@ list = ) create :: CreatePayment -> ActionM () -create (CreatePayment name cost date category frequency) = +create createPayment@(CreatePayment name cost date category frequency) = Secure.loggedAction (\user -> - (liftIO . Query.run $ do - PaymentCategoryPersistence.save name category - PaymentPersistence.create (_user_id user) name cost date frequency - ) >>= Json.jsonId + case CreatePaymentValidation.validate createPayment of + Nothing -> + (liftIO . Query.run $ do + PaymentCategoryPersistence.save name category + PaymentPersistence.create (_user_id user) name cost date frequency + ) >>= Json.jsonId + Just validationError -> + do + status Status.badRequest400 + json validationError ) editOwn :: EditPayment -> ActionM () -- cgit v1.2.3 From 50fb8fa48d1c4881da20b4ecf6d68a772301e713 Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 30 Oct 2018 18:04:58 +0100 Subject: Update table when adding or removing a payment --- server/src/Controller/Payment.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) (limited to 'server/src/Controller') diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index 4edbf6a..fb7fcb2 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -12,8 +12,6 @@ import Web.Scotty import Common.Model (CreatePayment (..), EditPayment (..), PaymentId, User (..)) - -import qualified Json import qualified Model.Query as Query import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.PaymentCategory as PaymentCategoryPersistence @@ -34,7 +32,7 @@ create createPayment@(CreatePayment name cost date category frequency) = (liftIO . Query.run $ do PaymentCategoryPersistence.save name category PaymentPersistence.create (_user_id user) name cost date frequency - ) >>= Json.jsonId + ) >>= json Just validationError -> do status Status.badRequest400 -- cgit v1.2.3 From 86957359ecf54c205aee1c09e151172c327e987a Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 31 Oct 2018 19:03:19 +0100 Subject: Various fixes --- server/src/Controller/Index.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'server/src/Controller') diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index f942540..0b276d3 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -6,6 +6,7 @@ module Controller.Index ) where import Control.Monad.IO.Class (liftIO) +import qualified Data.Aeson as Json import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -60,7 +61,7 @@ askSignIn conf (SignIn email) = ] maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email] case maybeSentMail of - Right _ -> textKey ok200 Msg.SignIn_EmailSent + Right _ -> S.json (Json.String . Msg.get $ Msg.SignIn_EmailSent) Left _ -> textKey badRequest400 Msg.SignIn_EmailSendFail Nothing -> textKey badRequest400 Msg.Secure_Unauthorized else textKey badRequest400 Msg.SignIn_EmailInvalid -- cgit v1.2.3 From 2741f47ef7b87255203bc2f7f7b2b9140c70b8f0 Mon Sep 17 00:00:00 2001 From: Joris Date: Thu, 1 Nov 2018 13:14:25 +0100 Subject: Implementing client side validation --- server/src/Controller/Index.hs | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) (limited to 'server/src/Controller') diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index 0b276d3..fbda527 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -9,18 +9,18 @@ import Control.Monad.IO.Class (liftIO) import qualified Data.Aeson as Json import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as TL import Data.Time.Clock (diffUTCTime, getCurrentTime) -import Network.HTTP.Types.Status (badRequest400, ok200) +import qualified Network.HTTP.Types.Status as Status import Prelude hiding (error) import Web.Scotty (ActionM) import qualified Web.Scotty as S -import Common.Model (InitResult (..), SignIn (..), - User (..)) +import Common.Model (Email (..), InitResult (..), + SignInForm (..), User (..)) import Common.Msg (Key) import qualified Common.Msg as Msg +import qualified Common.Validation.SignIn as SignInValidation import Conf (Conf (..)) import qualified LoginSession @@ -30,7 +30,6 @@ 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 import View.Page (page) @@ -45,10 +44,12 @@ get conf = do 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 +askSignIn :: Conf -> SignInForm -> ActionM () +askSignIn conf form = + case SignInValidation.signIn form of + Nothing -> + textKey Status.badRequest400 Msg.SignIn_EmailInvalid + Just (Email email) -> do maybeUser <- liftIO . Query.run $ UserPersistence.get email case maybeUser of Just user -> do @@ -62,9 +63,8 @@ askSignIn conf (SignIn email) = maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email] case maybeSentMail of Right _ -> S.json (Json.String . Msg.get $ Msg.SignIn_EmailSent) - Left _ -> textKey badRequest400 Msg.SignIn_EmailSendFail - Nothing -> textKey badRequest400 Msg.Secure_Unauthorized - else textKey badRequest400 Msg.SignIn_EmailInvalid + Left _ -> textKey Status.badRequest400 Msg.SignIn_EmailSendFail + Nothing -> textKey Status.badRequest400 Msg.Secure_Unauthorized where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key) trySignIn :: Conf -> Text -> ActionM () @@ -116,4 +116,4 @@ getLoggedUser = do liftIO . Query.run . Secure.getUserFromToken $ token signOut :: Conf -> ActionM () -signOut conf = LoginSession.delete conf >> S.status ok200 +signOut conf = LoginSession.delete conf >> S.status Status.ok200 -- cgit v1.2.3 From bc81084933f8ec1bfe6c2834defd12243117fdd9 Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 5 Aug 2019 21:53:30 +0200 Subject: Use updated payment categories from payment add in payment’s table --- server/src/Controller/Payment.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'server/src/Controller') diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index fb7fcb2..e82fd49 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -10,6 +10,7 @@ import qualified Network.HTTP.Types.Status as Status import Web.Scotty import Common.Model (CreatePayment (..), + CreatedPayment (..), EditPayment (..), PaymentId, User (..)) import qualified Model.Query as Query @@ -30,8 +31,9 @@ create createPayment@(CreatePayment name cost date category frequency) = case CreatePaymentValidation.validate createPayment of Nothing -> (liftIO . Query.run $ do - PaymentCategoryPersistence.save name category - PaymentPersistence.create (_user_id user) name cost date frequency + pc <- PaymentCategoryPersistence.save name category + p <- PaymentPersistence.create (_user_id user) name cost date frequency + return $ CreatedPayment p pc ) >>= json Just validationError -> do -- cgit v1.2.3 From fb8f0fe577e28dae69903413b761da50586e0099 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 10 Aug 2019 14:53:41 +0200 Subject: Remove payment category if unused after a payment is deleted --- server/src/Controller/Income.hs | 33 +++++++++++++-------------------- server/src/Controller/Payment.hs | 37 +++++++++++++++++++++++-------------- 2 files changed, 36 insertions(+), 34 deletions(-) (limited to 'server/src/Controller') diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 3f623e5..ed58ac8 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -1,17 +1,15 @@ module Controller.Income ( create - , editOwn - , deleteOwn + , edit + , 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 +import qualified Network.HTTP.Types.Status as Status +import Web.Scotty hiding (delete) import Common.Model (CreateIncome (..), EditIncome (..), IncomeId, User (..)) -import qualified Common.Msg as Msg import Json (jsonId) import qualified Model.Query as Query @@ -24,23 +22,18 @@ create (CreateIncome date amount) = (liftIO . Query.run $ IncomePersistence.create (_user_id user) date amount) >>= jsonId ) -editOwn :: EditIncome -> ActionM () -editOwn (EditIncome incomeId date amount) = +edit :: EditIncome -> ActionM () +edit (EditIncome incomeId date amount) = Secure.loggedAction (\user -> do - updated <- liftIO . Query.run $ IncomePersistence.editOwn (_user_id user) incomeId date amount + updated <- liftIO . Query.run $ IncomePersistence.edit (_user_id user) incomeId date amount if updated - then status ok200 - else status badRequest400 + then status Status.ok200 + else status Status.badRequest400 ) -deleteOwn :: IncomeId -> ActionM () -deleteOwn incomeId = +delete :: IncomeId -> ActionM () +delete incomeId = Secure.loggedAction (\user -> do - deleted <- liftIO . Query.run $ IncomePersistence.deleteOwn user incomeId - if deleted - then - status ok200 - else do - status badRequest400 - text . TL.fromStrict $ Msg.get Msg.Income_NotDeleted + _ <- liftIO . Query.run $ IncomePersistence.delete (_user_id user) incomeId + status Status.ok200 ) diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index e82fd49..3d857be 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -1,18 +1,18 @@ module Controller.Payment ( list , create - , editOwn - , deleteOwn + , edit + , delete ) where import Control.Monad.IO.Class (liftIO) import qualified Network.HTTP.Types.Status as Status -import Web.Scotty +import Web.Scotty hiding (delete) import Common.Model (CreatePayment (..), CreatedPayment (..), - EditPayment (..), PaymentId, - User (..)) + EditPayment (..), Payment (..), + PaymentId, User (..)) import qualified Model.Query as Query import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.PaymentCategory as PaymentCategoryPersistence @@ -41,11 +41,11 @@ create createPayment@(CreatePayment name cost date category frequency) = json validationError ) -editOwn :: EditPayment -> ActionM () -editOwn (EditPayment paymentId name cost date category frequency) = +edit :: EditPayment -> ActionM () +edit (EditPayment paymentId name cost date category frequency) = Secure.loggedAction (\user -> do updated <- liftIO . Query.run $ do - edited <- PaymentPersistence.editOwn (_user_id user) paymentId name cost date frequency + edited <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency _ <- if edited then PaymentCategoryPersistence.save name category >> return () else return () @@ -55,11 +55,20 @@ editOwn (EditPayment paymentId name cost date category frequency) = else status Status.badRequest400 ) -deleteOwn :: PaymentId -> ActionM () -deleteOwn paymentId = +delete :: PaymentId -> ActionM () +delete paymentId = Secure.loggedAction (\user -> do - deleted <- liftIO . Query.run $ PaymentPersistence.deleteOwn (_user_id user) paymentId - if deleted - then status Status.ok200 - else status Status.badRequest400 + deleted <- liftIO . Query.run $ do + payment <- PaymentPersistence.find paymentId + case payment of + Just p | _payment_user p == _user_id user -> do + PaymentPersistence.delete (_user_id user) paymentId + PaymentCategoryPersistence.deleteIfUnused (_payment_name p) + return True + _ -> + return False + if deleted then + status Status.ok200 + else + status Status.badRequest400 ) -- cgit v1.2.3 From 2d79ab0e0a11f55255fc21a5dfab1598d3beeba3 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 11 Aug 2019 22:40:09 +0200 Subject: Add payment clone --- server/src/Controller/Payment.hs | 29 +++++++++++++++++------------ 1 file changed, 17 insertions(+), 12 deletions(-) (limited to 'server/src/Controller') diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index 3d857be..c700240 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -10,9 +10,9 @@ import qualified Network.HTTP.Types.Status as Status import Web.Scotty hiding (delete) import Common.Model (CreatePayment (..), - CreatedPayment (..), EditPayment (..), Payment (..), - PaymentId, User (..)) + PaymentId, SavedPayment (..), + User (..)) import qualified Model.Query as Query import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.PaymentCategory as PaymentCategoryPersistence @@ -33,7 +33,7 @@ create createPayment@(CreatePayment name cost date category frequency) = (liftIO . Query.run $ do pc <- PaymentCategoryPersistence.save name category p <- PaymentPersistence.create (_user_id user) name cost date frequency - return $ CreatedPayment p pc + return $ SavedPayment p pc ) >>= json Just validationError -> do @@ -44,15 +44,20 @@ create createPayment@(CreatePayment name cost date category frequency) = edit :: EditPayment -> ActionM () edit (EditPayment paymentId name cost date category frequency) = Secure.loggedAction (\user -> do - updated <- liftIO . Query.run $ do - edited <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency - _ <- if edited - then PaymentCategoryPersistence.save name category >> return () - else return () - return edited - if updated - then status Status.ok200 - else status Status.badRequest400 + result <- liftIO . Query.run $ do + editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency + case editedPayment of + Just p -> do + pc <- PaymentCategoryPersistence.save name category + PaymentCategoryPersistence.deleteIfUnused name + return $ Just (p, pc) + Nothing -> + return Nothing + case result of + Just (p, pc) -> + json $ SavedPayment p pc + Nothing -> + status Status.badRequest400 ) delete :: PaymentId -> ActionM () -- cgit v1.2.3 From f4c5df9e1b1afddeb5a482d4fbe654d0b321159c Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 6 Oct 2019 19:28:54 +0200 Subject: Make payment edition to work on the frontend --- server/src/Controller/Payment.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'server/src/Controller') diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index c700240..38c1c19 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -47,10 +47,10 @@ edit (EditPayment paymentId name cost date category frequency) = result <- liftIO . Query.run $ do editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency case editedPayment of - Just p -> do + Just (old, new) -> do pc <- PaymentCategoryPersistence.save name category - PaymentCategoryPersistence.deleteIfUnused name - return $ Just (p, pc) + PaymentCategoryPersistence.deleteIfUnused (_payment_name old) + return $ Just (new, pc) Nothing -> return Nothing case result of -- cgit v1.2.3 From 7529a18ff0ac443e7f9764b5e2d0f57a5d3a850b Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 9 Oct 2019 23:16:00 +0200 Subject: Use common payment validation in the backend Remove deprecated backend validation --- server/src/Controller/Helper.hs | 17 ++++++++++ server/src/Controller/Payment.hs | 73 ++++++++++++++++++++++------------------ 2 files changed, 57 insertions(+), 33 deletions(-) create mode 100644 server/src/Controller/Helper.hs (limited to 'server/src/Controller') diff --git a/server/src/Controller/Helper.hs b/server/src/Controller/Helper.hs new file mode 100644 index 0000000..fd0d2bb --- /dev/null +++ b/server/src/Controller/Helper.hs @@ -0,0 +1,17 @@ +module Controller.Helper + ( jsonOrBadRequest + ) where + +import Data.Aeson (ToJSON) +import Data.Text (Text) +import qualified Data.Text.Lazy as LT +import qualified Network.HTTP.Types.Status as Status +import Web.Scotty (ActionM) +import qualified Web.Scotty as S + +jsonOrBadRequest :: forall a. (ToJSON a) => Either Text a -> ActionM () +jsonOrBadRequest (Left message) = do + S.status Status.badRequest400 + S.text (LT.fromStrict message) +jsonOrBadRequest (Right a) = + S.json a diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index 38c1c19..ba9d1ba 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -6,18 +6,25 @@ module Controller.Payment ) where import Control.Monad.IO.Class (liftIO) +import Data.Validation (Validation (Failure, Success)) import qualified Network.HTTP.Types.Status as Status import Web.Scotty hiding (delete) -import Common.Model (CreatePayment (..), - EditPayment (..), Payment (..), - PaymentId, SavedPayment (..), - User (..)) +import Common.Model (Category (..), + CreatePaymentForm (..), + EditPaymentForm (..), + Payment (..), PaymentId, + SavedPayment (..), User (..)) +import qualified Common.Msg as Msg +import qualified Controller.Helper as ControllerHelper +import Model.CreatePayment (CreatePayment (..)) +import Model.EditPayment (EditPayment (..)) import qualified Model.Query as Query +import qualified Persistence.Category as CategoryPersistence import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.PaymentCategory as PaymentCategoryPersistence import qualified Secure -import qualified Validation.CreatePayment as CreatePaymentValidation +import qualified Validation.Payment as PaymentValidation list :: ActionM () list = @@ -25,39 +32,39 @@ list = (liftIO . Query.run $ PaymentPersistence.listActive) >>= json ) -create :: CreatePayment -> ActionM () -create createPayment@(CreatePayment name cost date category frequency) = +create :: CreatePaymentForm -> ActionM () +create form = Secure.loggedAction (\user -> - case CreatePaymentValidation.validate createPayment of - Nothing -> - (liftIO . Query.run $ do + (liftIO . Query.run $ do + cs <- map _category_id <$> CategoryPersistence.list + case PaymentValidation.createPayment cs form of + Success (CreatePayment name cost date category frequency) -> do pc <- PaymentCategoryPersistence.save name category p <- PaymentPersistence.create (_user_id user) name cost date frequency - return $ SavedPayment p pc - ) >>= json - Just validationError -> - do - status Status.badRequest400 - json validationError + return . Right $ SavedPayment p pc + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.jsonOrBadRequest ) -edit :: EditPayment -> ActionM () -edit (EditPayment paymentId name cost date category frequency) = - Secure.loggedAction (\user -> do - result <- liftIO . Query.run $ do - editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency - case editedPayment of - Just (old, new) -> do - pc <- PaymentCategoryPersistence.save name category - PaymentCategoryPersistence.deleteIfUnused (_payment_name old) - return $ Just (new, pc) - Nothing -> - return Nothing - case result of - Just (p, pc) -> - json $ SavedPayment p pc - Nothing -> - status Status.badRequest400 +edit :: EditPaymentForm -> ActionM () +edit form = + Secure.loggedAction (\user -> + (liftIO . Query.run $ do + cs <- map _category_id <$> CategoryPersistence.list + case PaymentValidation.editPayment cs form of + Success (EditPayment paymentId name cost date category frequency) -> do + editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency + case editedPayment of + Just (old, new) -> do + pc <- PaymentCategoryPersistence.save name category + PaymentCategoryPersistence.deleteIfUnused (_payment_name old) + return . Right $ SavedPayment new pc + Nothing -> + return . Left $ Msg.get Msg.Error_PaymentEdit + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.jsonOrBadRequest ) delete :: PaymentId -> ActionM () -- cgit v1.2.3 From 52331eeadce8d250564851c25fc965172640bc55 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 12 Oct 2019 11:23:10 +0200 Subject: Implement client routing --- server/src/Controller/Index.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'server/src/Controller') diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index fbda527..5ebe921 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -57,7 +57,7 @@ askSignIn conf form = let url = T.concat [ if Conf.https conf then "https://" else "http://", Conf.hostname conf, - "/signIn/", + "/api/signIn/", token ] maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email] -- cgit v1.2.3 From 7aadcc97f9df0e2daccbe8a8726d8bc6c63d67f4 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 20 Oct 2019 12:02:21 +0200 Subject: Add income --- server/src/Controller/Income.hs | 23 +++++++++++++++++------ 1 file changed, 17 insertions(+), 6 deletions(-) (limited to 'server/src/Controller') diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index ed58ac8..e013849 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -5,21 +5,32 @@ module Controller.Income ) where import Control.Monad.IO.Class (liftIO) +import Data.Validation (Validation (Failure, Success)) import qualified Network.HTTP.Types.Status as Status import Web.Scotty hiding (delete) -import Common.Model (CreateIncome (..), EditIncome (..), - IncomeId, User (..)) +import Common.Model (CreateIncomeForm (..), + EditIncome (..), IncomeId, + User (..)) -import Json (jsonId) +import qualified Controller.Helper as ControllerHelper +import Model.CreateIncome (CreateIncome (..)) import qualified Model.Query as Query import qualified Persistence.Income as IncomePersistence import qualified Secure +import qualified Validation.Income as IncomeValidation -create :: CreateIncome -> ActionM () -create (CreateIncome date amount) = +create :: CreateIncomeForm -> ActionM () +create form = Secure.loggedAction (\user -> - (liftIO . Query.run $ IncomePersistence.create (_user_id user) date amount) >>= jsonId + (liftIO . Query.run $ do + case IncomeValidation.createIncome form of + Success (CreateIncome amount date) -> do + Right <$> (IncomePersistence.create (_user_id user) date amount) + + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.jsonOrBadRequest ) edit :: EditIncome -> ActionM () -- cgit v1.2.3 From 602c52acfcfa494b07fec05c20b317b60ea8a6f3 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 20 Oct 2019 21:31:57 +0200 Subject: Load init data per page with AJAX --- server/src/Controller/Category.hs | 9 ++++++++- server/src/Controller/Income.hs | 9 ++++++++- server/src/Controller/Index.hs | 11 ++++++----- server/src/Controller/Payment.hs | 7 +++++++ server/src/Controller/User.hs | 17 +++++++++++++++++ 5 files changed, 46 insertions(+), 7 deletions(-) create mode 100644 server/src/Controller/User.hs (limited to 'server/src/Controller') diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs index 37b8357..e536caa 100644 --- a/server/src/Controller/Category.hs +++ b/server/src/Controller/Category.hs @@ -1,5 +1,6 @@ module Controller.Category - ( create + ( list + , create , edit , delete ) where @@ -19,6 +20,12 @@ import qualified Persistence.Category as CategoryPersistence import qualified Persistence.PaymentCategory as PaymentCategoryPersistence import qualified Secure +list :: ActionM () +list = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ CategoryPersistence.list) >>= json + ) + create :: CreateCategory -> ActionM () create (CreateCategory name color) = Secure.loggedAction (\_ -> diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index e013849..b40976b 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -1,5 +1,6 @@ module Controller.Income - ( create + ( list + , create , edit , delete ) where @@ -20,6 +21,12 @@ import qualified Persistence.Income as IncomePersistence import qualified Secure import qualified Validation.Income as IncomeValidation +list :: ActionM () +list = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ IncomePersistence.list) >>= json + ) + create :: CreateIncomeForm -> ActionM () create form = Secure.loggedAction (\user -> diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index 5ebe921..3788685 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -16,8 +16,9 @@ import Prelude hiding (error) import Web.Scotty (ActionM) import qualified Web.Scotty as S -import Common.Model (Email (..), InitResult (..), - SignInForm (..), User (..)) +import Common.Model (Email (..), Init (..), + InitResult (..), SignInForm (..), + User (..)) import Common.Msg (Key) import qualified Common.Msg as Msg import qualified Common.Validation.SignIn as SignInValidation @@ -26,7 +27,6 @@ import Conf (Conf (..)) import qualified LoginSession import qualified Model.Query as Query import qualified Model.SignIn as SignIn -import qualified Persistence.Init as InitPersistence import qualified Persistence.User as UserPersistence import qualified Secure import qualified SendMail @@ -40,8 +40,9 @@ get conf = do case mbLoggedUser of Nothing -> return InitEmpty - Just user -> - liftIO . Query.run . fmap InitSuccess $ InitPersistence.getInit user conf + Just user -> do + users <- liftIO . Query.run $ UserPersistence.list + return . InitSuccess $ Init users (_user_id user) (Conf.currency conf) S.html $ page initResult askSignIn :: Conf -> SignInForm -> ActionM () diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index ba9d1ba..30b63ff 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -1,5 +1,6 @@ module Controller.Payment ( list + , listPaymentCategories , create , edit , delete @@ -32,6 +33,12 @@ list = (liftIO . Query.run $ PaymentPersistence.listActive) >>= json ) +listPaymentCategories :: ActionM () +listPaymentCategories = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ PaymentCategoryPersistence.list) >>= json + ) + create :: CreatePaymentForm -> ActionM () create form = Secure.loggedAction (\user -> diff --git a/server/src/Controller/User.hs b/server/src/Controller/User.hs new file mode 100644 index 0000000..a7bb136 --- /dev/null +++ b/server/src/Controller/User.hs @@ -0,0 +1,17 @@ +module Controller.User + ( list + ) where + +import Control.Monad.IO.Class (liftIO) +import Web.Scotty (ActionM) +import qualified Web.Scotty as S + +import qualified Model.Query as Query +import qualified Persistence.User as UserPersistence +import qualified Secure + +list :: ActionM () +list = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ UserPersistence.list) >>= S.json + ) -- cgit v1.2.3 From e4b32ce15f8c92f3b477d3f3d4d301ba08f9b5e3 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 23 Oct 2019 22:35:27 +0200 Subject: Edit an income --- server/src/Controller/Income.hs | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) (limited to 'server/src/Controller') diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index b40976b..236e032 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -11,11 +11,12 @@ import qualified Network.HTTP.Types.Status as Status import Web.Scotty hiding (delete) import Common.Model (CreateIncomeForm (..), - EditIncome (..), IncomeId, + EditIncomeForm (..), IncomeId, User (..)) import qualified Controller.Helper as ControllerHelper import Model.CreateIncome (CreateIncome (..)) +import Model.EditIncome (EditIncome (..)) import qualified Model.Query as Query import qualified Persistence.Income as IncomePersistence import qualified Secure @@ -40,13 +41,17 @@ create form = ) >>= ControllerHelper.jsonOrBadRequest ) -edit :: EditIncome -> ActionM () -edit (EditIncome incomeId date amount) = - Secure.loggedAction (\user -> do - updated <- liftIO . Query.run $ IncomePersistence.edit (_user_id user) incomeId date amount - if updated - then status Status.ok200 - else status Status.badRequest400 +edit :: EditIncomeForm -> ActionM () +edit form = + Secure.loggedAction (\user -> + (liftIO . Query.run $ do + case IncomeValidation.editIncome form of + Success (EditIncome incomeId amount date) -> do + Right <$> (IncomePersistence.edit (_user_id user) incomeId date amount) + + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.jsonOrBadRequest ) delete :: IncomeId -> ActionM () -- cgit v1.2.3 From b97ad942495352c3fc1e0c820cfba82a9693ac7a Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 27 Oct 2019 20:26:29 +0100 Subject: WIP Set up server side paging for incomes --- server/src/Controller/Income.hs | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) (limited to 'server/src/Controller') diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 236e032..3272cbf 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -1,5 +1,6 @@ module Controller.Income ( list + , listv2 , create , edit , delete @@ -12,7 +13,7 @@ import Web.Scotty hiding (delete) import Common.Model (CreateIncomeForm (..), EditIncomeForm (..), IncomeId, - User (..)) + IncomesAndCount (..), User (..)) import qualified Controller.Helper as ControllerHelper import Model.CreateIncome (CreateIncome (..)) @@ -28,6 +29,16 @@ list = (liftIO . Query.run $ IncomePersistence.list) >>= json ) +listv2 :: Int -> Int -> ActionM () +listv2 page perPage = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ do + count <- IncomePersistence.count + incomes <- IncomePersistence.listv2 page perPage + return $ IncomesAndCount incomes count + ) >>= json + ) + create :: CreateIncomeForm -> ActionM () create form = Secure.loggedAction (\user -> -- cgit v1.2.3 From 9dbb4e6f7c2f0edc1126626e2ff498144c6b9947 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 3 Nov 2019 11:28:42 +0100 Subject: Show income header --- server/src/Controller/Income.hs | 49 ++++++++++++++++++++++++++++------------- 1 file changed, 34 insertions(+), 15 deletions(-) (limited to 'server/src/Controller') diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 3272cbf..d8d3d89 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -1,42 +1,61 @@ module Controller.Income ( list - , listv2 , create , edit , delete ) where import Control.Monad.IO.Class (liftIO) +import qualified Data.Map as M +import qualified Data.Time.Clock as Clock import Data.Validation (Validation (Failure, Success)) import qualified Network.HTTP.Types.Status as Status import Web.Scotty hiding (delete) import Common.Model (CreateIncomeForm (..), - EditIncomeForm (..), IncomeId, - IncomesAndCount (..), User (..)) + EditIncomeForm (..), Income (..), + IncomeHeader (..), IncomeId, + IncomePage (..), User (..)) +import qualified Common.Model as CM import qualified Controller.Helper as ControllerHelper import Model.CreateIncome (CreateIncome (..)) import Model.EditIncome (EditIncome (..)) import qualified Model.Query as Query import qualified Persistence.Income as IncomePersistence +import qualified Persistence.Payment as PaymentPersistence +import qualified Persistence.User as UserPersistence import qualified Secure import qualified Validation.Income as IncomeValidation -list :: ActionM () -list = - Secure.loggedAction (\_ -> - (liftIO . Query.run $ IncomePersistence.list) >>= json - ) - -listv2 :: Int -> Int -> ActionM () -listv2 page perPage = - Secure.loggedAction (\_ -> +list :: Int -> Int -> ActionM () +list page perPage = + Secure.loggedAction (\_ -> do + currentTime <- liftIO Clock.getCurrentTime (liftIO . Query.run $ do count <- IncomePersistence.count - incomes <- IncomePersistence.listv2 page perPage - return $ IncomesAndCount incomes count - ) >>= json + + users <- UserPersistence.list + allPayments <- PaymentPersistence.listPunctual -- TODO: get first payment defined for all + allIncomes <- IncomePersistence.listAll + + let since = + CM.useIncomesFrom (map _user_id users) allIncomes allPayments + + let byUser = + case since of + Just s -> + M.fromList . flip map users $ \user -> + ( _user_id user + , CM.cumulativeIncomesSince currentTime s $ + filter ((==) (_user_id user) . _income_userId) allIncomes + ) + + Nothing -> + M.empty + + incomes <- IncomePersistence.list page perPage + return $ IncomePage (IncomeHeader since byUser) incomes count) >>= json ) create :: CreateIncomeForm -> ActionM () -- cgit v1.2.3 From 182f3d3fea9985c0e403087fe253981c68e57102 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 3 Nov 2019 11:33:20 +0100 Subject: Fix payment page --- server/src/Controller/Income.hs | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'server/src/Controller') diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index d8d3d89..4a41bd3 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -1,5 +1,6 @@ module Controller.Income ( list + , deprecatedList , create , edit , delete @@ -58,6 +59,12 @@ list page perPage = return $ IncomePage (IncomeHeader since byUser) incomes count) >>= json ) +deprecatedList :: ActionM () +deprecatedList = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ IncomePersistence.listAll) >>= json + ) + create :: CreateIncomeForm -> ActionM () create form = Secure.loggedAction (\user -> -- cgit v1.2.3 From 0f85cbd8ee736b1996e3966bac1f5e47ed7d27a9 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 3 Nov 2019 15:47:11 +0100 Subject: Fetch the first payment date instead of every payment to get cumulative income --- server/src/Controller/Income.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'server/src/Controller') diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 4a41bd3..127e3b3 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -37,11 +37,11 @@ list page perPage = count <- IncomePersistence.count users <- UserPersistence.list - allPayments <- PaymentPersistence.listPunctual -- TODO: get first payment defined for all + firstPayment <- PaymentPersistence.firstPunctualDay allIncomes <- IncomePersistence.listAll let since = - CM.useIncomesFrom (map _user_id users) allIncomes allPayments + CM.useIncomesFrom (map _user_id users) allIncomes firstPayment let byUser = case since of -- cgit v1.2.3 From f4f24158a46d8c0975f1b8813bbdbbeebad8c108 Mon Sep 17 00:00:00 2001 From: Joris Date: Wed, 6 Nov 2019 19:44:15 +0100 Subject: Show the payment table with server side paging --- server/src/Controller/Payment.hs | 19 ++++++++++++++++--- 1 file changed, 16 insertions(+), 3 deletions(-) (limited to 'server/src/Controller') diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index 30b63ff..01702cb 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -1,5 +1,6 @@ module Controller.Payment - ( list + ( deprecatedList + , list , listPaymentCategories , create , edit @@ -15,6 +16,7 @@ import Common.Model (Category (..), CreatePaymentForm (..), EditPaymentForm (..), Payment (..), PaymentId, + PaymentPage (..), SavedPayment (..), User (..)) import qualified Common.Msg as Msg import qualified Controller.Helper as ControllerHelper @@ -27,12 +29,23 @@ import qualified Persistence.PaymentCategory as PaymentCategoryPersistence import qualified Secure import qualified Validation.Payment as PaymentValidation -list :: ActionM () -list = +deprecatedList :: ActionM () +deprecatedList = Secure.loggedAction (\_ -> (liftIO . Query.run $ PaymentPersistence.listActive) >>= json ) +list :: Int -> Int -> ActionM () +list page perPage = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ do + count <- PaymentPersistence.count + payments <- PaymentPersistence.listActivePage page perPage + paymentCategories <- PaymentCategoryPersistence.list + return $ PaymentPage payments paymentCategories count + ) >>= json + ) + listPaymentCategories :: ActionM () listPaymentCategories = Secure.loggedAction (\_ -> -- cgit v1.2.3 From 4dc84dbda7ba3ea60d13e6f81eeec556974b7c72 Mon Sep 17 00:00:00 2001 From: Joris Date: Thu, 7 Nov 2019 07:59:41 +0100 Subject: Show payment header infos --- server/src/Controller/Payment.hs | 54 +++++++++++++++++++++++++++------------- 1 file changed, 37 insertions(+), 17 deletions(-) (limited to 'server/src/Controller') diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index 01702cb..f685f2e 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -1,6 +1,5 @@ module Controller.Payment - ( deprecatedList - , list + ( list , listPaymentCategories , create , edit @@ -8,48 +7,69 @@ module Controller.Payment ) where import Control.Monad.IO.Class (liftIO) +import qualified Data.Map as M +import qualified Data.Time.Clock as Clock import Data.Validation (Validation (Failure, Success)) import qualified Network.HTTP.Types.Status as Status -import Web.Scotty hiding (delete) +import Web.Scotty (ActionM) +import qualified Web.Scotty as S import Common.Model (Category (..), CreatePaymentForm (..), EditPaymentForm (..), - Payment (..), PaymentId, - PaymentPage (..), + Frequency (Punctual), + Payment (..), PaymentHeader (..), + PaymentId, PaymentPage (..), SavedPayment (..), User (..)) +import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Controller.Helper as ControllerHelper import Model.CreatePayment (CreatePayment (..)) import Model.EditPayment (EditPayment (..)) import qualified Model.Query as 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 import qualified Secure +import qualified Util.List as L import qualified Validation.Payment as PaymentValidation -deprecatedList :: ActionM () -deprecatedList = - Secure.loggedAction (\_ -> - (liftIO . Query.run $ PaymentPersistence.listActive) >>= json - ) - list :: Int -> Int -> ActionM () list page perPage = - Secure.loggedAction (\_ -> + Secure.loggedAction (\_ -> do + currentTime <- liftIO Clock.getCurrentTime (liftIO . Query.run $ do count <- PaymentPersistence.count payments <- PaymentPersistence.listActivePage page perPage paymentCategories <- PaymentCategoryPersistence.list - return $ PaymentPage payments paymentCategories count - ) >>= json + + users <- UserPersistence.list + incomes <- IncomePersistence.listAll + allPayments <- PaymentPersistence.listActive Punctual + + let exceedingPayers = CM.getExceedingPayers currentTime users incomes allPayments + + repartition = + M.fromList + . map (\(u, xs) -> (u, sum . map snd $ xs)) + . L.groupBy fst + . map (\p -> (_payment_user p, _payment_cost p)) + $ allPayments + + header = PaymentHeader + { _paymentHeader_exceedingPayers = exceedingPayers + , _paymentHeader_repartition = repartition + } + + return $ PaymentPage header payments paymentCategories count) >>= S.json ) listPaymentCategories :: ActionM () listPaymentCategories = Secure.loggedAction (\_ -> - (liftIO . Query.run $ PaymentCategoryPersistence.list) >>= json + (liftIO . Query.run $ PaymentCategoryPersistence.list) >>= S.json ) create :: CreatePaymentForm -> ActionM () @@ -100,7 +120,7 @@ delete paymentId = _ -> return False if deleted then - status Status.ok200 + S.status Status.ok200 else - status Status.badRequest400 + S.status Status.badRequest400 ) -- cgit v1.2.3 From c0ea63f8c1a8c7123b78798cec99726b113fb1f3 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 17 Nov 2019 18:08:28 +0100 Subject: Optimize and refactor payments --- server/src/Controller/Category.hs | 27 ++++---- server/src/Controller/Income.hs | 17 ++--- server/src/Controller/Payment.hs | 137 +++++++++++++++++--------------------- 3 files changed, 78 insertions(+), 103 deletions(-) (limited to 'server/src/Controller') diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs index e536caa..8fbc8c8 100644 --- a/server/src/Controller/Category.hs +++ b/server/src/Controller/Category.hs @@ -5,19 +5,18 @@ 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.Query as Query -import qualified Persistence.Category as CategoryPersistence -import qualified Persistence.PaymentCategory as PaymentCategoryPersistence +import Json (jsonId) +import qualified Model.Query as Query +import qualified Persistence.Category as CategoryPersistence import qualified Secure list :: ActionM () @@ -45,10 +44,8 @@ delete :: CategoryId -> ActionM () delete categoryId = Secure.loggedAction (\_ -> do deleted <- liftIO . Query.run $ do - paymentCategories <- PaymentCategoryPersistence.listByCategory categoryId - if null paymentCategories - then CategoryPersistence.delete categoryId - else return False + -- TODO: delete only if no payment has this category + CategoryPersistence.delete categoryId if deleted then status ok200 diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 127e3b3..75d0133 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -1,6 +1,5 @@ module Controller.Income ( list - , deprecatedList , create , edit , delete @@ -17,12 +16,12 @@ import Common.Model (CreateIncomeForm (..), EditIncomeForm (..), Income (..), IncomeHeader (..), IncomeId, IncomePage (..), User (..)) -import qualified Common.Model as CM import qualified Controller.Helper as ControllerHelper import Model.CreateIncome (CreateIncome (..)) import Model.EditIncome (EditIncome (..)) import qualified Model.Query as Query +import qualified Payer as Payer import qualified Persistence.Income as IncomePersistence import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.User as UserPersistence @@ -37,18 +36,18 @@ list page perPage = count <- IncomePersistence.count users <- UserPersistence.list - firstPayment <- PaymentPersistence.firstPunctualDay - allIncomes <- IncomePersistence.listAll + paymentRange <- PaymentPersistence.getRange + allIncomes <- IncomePersistence.listAll -- TODO optimize let since = - CM.useIncomesFrom (map _user_id users) allIncomes firstPayment + Payer.useIncomesFrom (map _user_id users) allIncomes (fst <$> paymentRange) let byUser = case since of Just s -> M.fromList . flip map users $ \user -> ( _user_id user - , CM.cumulativeIncomesSince currentTime s $ + , Payer.cumulativeIncomesSince currentTime s $ filter ((==) (_user_id user) . _income_userId) allIncomes ) @@ -59,12 +58,6 @@ list page perPage = return $ IncomePage (IncomeHeader since byUser) incomes count) >>= json ) -deprecatedList :: ActionM () -deprecatedList = - Secure.loggedAction (\_ -> - (liftIO . Query.run $ IncomePersistence.listAll) >>= json - ) - create :: CreateIncomeForm -> ActionM () create form = Secure.loggedAction (\user -> diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index f685f2e..d4d086e 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -1,75 +1,70 @@ module Controller.Payment ( list - , listPaymentCategories , create , edit , delete + , searchCategory ) where -import Control.Monad.IO.Class (liftIO) -import qualified Data.Map as M -import qualified Data.Time.Clock as Clock -import Data.Validation (Validation (Failure, Success)) -import qualified Network.HTTP.Types.Status as Status -import Web.Scotty (ActionM) -import qualified Web.Scotty as S +import Control.Monad.IO.Class (liftIO) +import qualified Data.Map as M +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Time.Calendar as Calendar +import qualified Data.Time.Clock as Clock +import Data.Validation (Validation (Failure, Success)) +import Web.Scotty (ActionM) +import qualified Web.Scotty as S -import Common.Model (Category (..), - CreatePaymentForm (..), - EditPaymentForm (..), - Frequency (Punctual), - Payment (..), PaymentHeader (..), - PaymentId, PaymentPage (..), - SavedPayment (..), User (..)) -import qualified Common.Model as CM -import qualified Common.Msg as Msg -import qualified Controller.Helper as ControllerHelper -import Model.CreatePayment (CreatePayment (..)) -import Model.EditPayment (EditPayment (..)) -import qualified Model.Query as 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 +import Common.Model (Category (..), CreatePaymentForm (..), + EditPaymentForm (..), Frequency, + PaymentHeader (..), PaymentId, + PaymentPage (..), User (..)) +import qualified Common.Msg as Msg + +import qualified Controller.Helper as ControllerHelper +import Model.CreatePayment (CreatePayment (..)) +import Model.EditPayment (EditPayment (..)) +import qualified Model.Query as Query +import qualified Payer as Payer +import qualified Persistence.Category as CategoryPersistence +import qualified Persistence.Income as IncomePersistence +import qualified Persistence.Payment as PaymentPersistence +import qualified Persistence.User as UserPersistence import qualified Secure -import qualified Util.List as L -import qualified Validation.Payment as PaymentValidation +import qualified Validation.Payment as PaymentValidation -list :: Int -> Int -> ActionM () -list page perPage = +list :: Frequency -> Int -> Int -> Text -> ActionM () +list frequency page perPage search = Secure.loggedAction (\_ -> do currentTime <- liftIO Clock.getCurrentTime (liftIO . Query.run $ do - count <- PaymentPersistence.count - payments <- PaymentPersistence.listActivePage page perPage - paymentCategories <- PaymentCategoryPersistence.list + count <- PaymentPersistence.count frequency search + payments <- PaymentPersistence.listActivePage frequency page perPage search users <- UserPersistence.list - incomes <- IncomePersistence.listAll - allPayments <- PaymentPersistence.listActive Punctual + incomes <- IncomePersistence.listAll -- TODO optimize + + paymentRange <- PaymentPersistence.getRange + + searchRepartition <- + case paymentRange of + Just (from, to) -> + PaymentPersistence.repartition frequency search from (Calendar.addDays 1 to) + Nothing -> + return M.empty - let exceedingPayers = CM.getExceedingPayers currentTime users incomes allPayments + (preIncomeRepartition, postIncomeRepartition) <- + PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users - repartition = - M.fromList - . map (\(u, xs) -> (u, sum . map snd $ xs)) - . L.groupBy fst - . map (\p -> (_payment_user p, _payment_cost p)) - $ allPayments + let exceedingPayers = Payer.getExceedingPayers currentTime users incomes preIncomeRepartition postIncomeRepartition (fst <$> paymentRange) header = PaymentHeader { _paymentHeader_exceedingPayers = exceedingPayers - , _paymentHeader_repartition = repartition + , _paymentHeader_repartition = searchRepartition } - return $ PaymentPage header payments paymentCategories count) >>= S.json - ) - -listPaymentCategories :: ActionM () -listPaymentCategories = - Secure.loggedAction (\_ -> - (liftIO . Query.run $ PaymentCategoryPersistence.list) >>= S.json + return $ PaymentPage page header payments count) >>= S.json ) create :: CreatePaymentForm -> ActionM () @@ -78,10 +73,8 @@ create form = (liftIO . Query.run $ do cs <- map _category_id <$> CategoryPersistence.list case PaymentValidation.createPayment cs form of - Success (CreatePayment name cost date category frequency) -> do - pc <- PaymentCategoryPersistence.save name category - p <- PaymentPersistence.create (_user_id user) name cost date frequency - return . Right $ SavedPayment p pc + Success (CreatePayment name cost date category frequency) -> + Right <$> PaymentPersistence.create (_user_id user) name cost date category frequency Failure validationError -> return $ Left validationError ) >>= ControllerHelper.jsonOrBadRequest @@ -94,14 +87,11 @@ edit form = cs <- map _category_id <$> CategoryPersistence.list case PaymentValidation.editPayment cs form of Success (EditPayment paymentId name cost date category frequency) -> do - editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date frequency - case editedPayment of - Just (old, new) -> do - pc <- PaymentCategoryPersistence.save name category - PaymentCategoryPersistence.deleteIfUnused (_payment_name old) - return . Right $ SavedPayment new pc - Nothing -> - return . Left $ Msg.get Msg.Error_PaymentEdit + editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date category frequency + if Maybe.isJust editedPayment then + return . Right $ editedPayment + else + return . Left $ Msg.get Msg.Error_PaymentEdit Failure validationError -> return $ Left validationError ) >>= ControllerHelper.jsonOrBadRequest @@ -109,18 +99,13 @@ edit form = delete :: PaymentId -> ActionM () delete paymentId = - Secure.loggedAction (\user -> do - deleted <- liftIO . Query.run $ do - payment <- PaymentPersistence.find paymentId - case payment of - Just p | _payment_user p == _user_id user -> do - PaymentPersistence.delete (_user_id user) paymentId - PaymentCategoryPersistence.deleteIfUnused (_payment_name p) - return True - _ -> - return False - if deleted then - S.status Status.ok200 - else - S.status Status.badRequest400 + Secure.loggedAction (\user -> + liftIO . Query.run $ PaymentPersistence.delete (_user_id user) paymentId + ) + +searchCategory :: Text -> ActionM () +searchCategory paymentName = + Secure.loggedAction (\_ -> do + (liftIO $ Query.run (PaymentPersistence.searchCategory paymentName)) + >>= S.json ) -- cgit v1.2.3 From 3c67fcf1d524811a18f0c4db3ef6eed1270b9a12 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 17 Nov 2019 19:55:22 +0100 Subject: Hide date from monthly payments --- server/src/Controller/Payment.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'server/src/Controller') diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index d4d086e..c860810 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -64,7 +64,7 @@ list frequency page perPage search = , _paymentHeader_repartition = searchRepartition } - return $ PaymentPage page header payments count) >>= S.json + return $ PaymentPage page frequency header payments count) >>= S.json ) create :: CreatePaymentForm -> ActionM () -- cgit v1.2.3 From 54628c70cb33de5e4309c35b9f6b57bbe9f7a07b Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 24 Nov 2019 16:19:53 +0100 Subject: Compute cumulative income with a DB query --- server/src/Controller/Income.hs | 28 ++++++++++------------------ server/src/Controller/Payment.hs | 16 +++++++++++----- 2 files changed, 21 insertions(+), 23 deletions(-) (limited to 'server/src/Controller') diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 75d0133..784a2db 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -13,7 +13,7 @@ import qualified Network.HTTP.Types.Status as Status import Web.Scotty hiding (delete) import Common.Model (CreateIncomeForm (..), - EditIncomeForm (..), Income (..), + EditIncomeForm (..), IncomeHeader (..), IncomeId, IncomePage (..), User (..)) @@ -21,7 +21,6 @@ import qualified Controller.Helper as ControllerHelper import Model.CreateIncome (CreateIncome (..)) import Model.EditIncome (EditIncome (..)) import qualified Model.Query as Query -import qualified Payer as Payer import qualified Persistence.Income as IncomePersistence import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.User as UserPersistence @@ -36,26 +35,19 @@ list page perPage = count <- IncomePersistence.count users <- UserPersistence.list - paymentRange <- PaymentPersistence.getRange - allIncomes <- IncomePersistence.listAll -- TODO optimize - - let since = - Payer.useIncomesFrom (map _user_id users) allIncomes (fst <$> paymentRange) + let userIds = _user_id <$> users - let byUser = - case since of - Just s -> - M.fromList . flip map users $ \user -> - ( _user_id user - , Payer.cumulativeIncomesSince currentTime s $ - filter ((==) (_user_id user) . _income_userId) allIncomes - ) + paymentRange <- PaymentPersistence.getRange + incomeDefinedForAll <- IncomePersistence.definedForAll userIds + let since = max <$> (fst <$> paymentRange) <*> incomeDefinedForAll - Nothing -> - M.empty + cumulativeIncome <- + case since of + Just s -> IncomePersistence.getCumulativeIncome s (Clock.utctDay currentTime) + Nothing -> return M.empty incomes <- IncomePersistence.list page perPage - return $ IncomePage (IncomeHeader since byUser) incomes count) >>= json + return $ IncomePage page (IncomeHeader since cumulativeIncome) incomes count) >>= json ) create :: CreateIncomeForm -> ActionM () diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index c860810..42a4436 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -11,7 +11,6 @@ import qualified Data.Map as M import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Time.Calendar as Calendar -import qualified Data.Time.Clock as Clock import Data.Validation (Validation (Failure, Success)) import Web.Scotty (ActionM) import qualified Web.Scotty as S @@ -36,16 +35,23 @@ import qualified Validation.Payment as PaymentValidation list :: Frequency -> Int -> Int -> Text -> ActionM () list frequency page perPage search = - Secure.loggedAction (\_ -> do - currentTime <- liftIO Clock.getCurrentTime + Secure.loggedAction (\_ -> (liftIO . Query.run $ do count <- PaymentPersistence.count frequency search payments <- PaymentPersistence.listActivePage frequency page perPage search users <- UserPersistence.list - incomes <- IncomePersistence.listAll -- TODO optimize paymentRange <- PaymentPersistence.getRange + incomeDefinedForAll <- IncomePersistence.definedForAll (_user_id <$> users) + + cumulativeIncome <- + case (incomeDefinedForAll, paymentRange) of + (Just incomeStart, Just (paymentStart, paymentEnd)) -> + IncomePersistence.getCumulativeIncome (max incomeStart paymentStart) paymentEnd + + _ -> + return M.empty searchRepartition <- case paymentRange of @@ -57,7 +63,7 @@ list frequency page perPage search = (preIncomeRepartition, postIncomeRepartition) <- PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users - let exceedingPayers = Payer.getExceedingPayers currentTime users incomes preIncomeRepartition postIncomeRepartition (fst <$> paymentRange) + let exceedingPayers = Payer.getExceedingPayers users cumulativeIncome preIncomeRepartition postIncomeRepartition header = PaymentHeader { _paymentHeader_exceedingPayers = exceedingPayers -- cgit v1.2.3 From 316bda10c6bec8b5ccc9e23f1f677c076205f046 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 8 Dec 2019 11:39:37 +0100 Subject: Add category page --- server/src/Controller/Category.hs | 66 +++++++++++++++++++++++++++++---------- server/src/Controller/Helper.hs | 11 +++---- server/src/Controller/Income.hs | 16 +++++++--- server/src/Controller/Payment.hs | 17 +++++----- 4 files changed, 73 insertions(+), 37 deletions(-) (limited to 'server/src/Controller') diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs index 8fbc8c8..36ce3fc 100644 --- a/server/src/Controller/Category.hs +++ b/server/src/Controller/Category.hs @@ -1,5 +1,6 @@ module Controller.Category - ( list + ( listAll + , list , create , edit , delete @@ -7,37 +8,68 @@ module Controller.Category import Control.Monad.IO.Class (liftIO) import qualified Data.Text.Lazy as TL +import Data.Validation (Validation (..)) import Network.HTTP.Types.Status (badRequest400, ok200) import Web.Scotty hiding (delete) -import Common.Model (CategoryId, CreateCategory (..), - EditCategory (..)) +import Common.Model (CategoryId, CategoryPage (..), + CreateCategoryForm (..), + EditCategoryForm (..)) import qualified Common.Msg as Msg -import Json (jsonId) +import qualified Controller.Helper as ControllerHelper +import Model.CreateCategory (CreateCategory (..)) +import Model.EditCategory (EditCategory (..)) import qualified Model.Query as Query import qualified Persistence.Category as CategoryPersistence import qualified Secure +import qualified Validation.Category as CategoryValidation -list :: ActionM () -list = +listAll :: ActionM () +listAll = Secure.loggedAction (\_ -> - (liftIO . Query.run $ CategoryPersistence.list) >>= json + (liftIO . Query.run $ CategoryPersistence.listAll) >>= json ) -create :: CreateCategory -> ActionM () -create (CreateCategory name color) = +list :: Int -> Int -> ActionM () +list page perPage = Secure.loggedAction (\_ -> - (liftIO . Query.run $ CategoryPersistence.create name color) >>= jsonId + (liftIO . Query.run $ do + categories <- CategoryPersistence.list page perPage + count <- CategoryPersistence.count + return $ CategoryPage page categories count + ) >>= json ) -edit :: EditCategory -> ActionM () -edit (EditCategory categoryId name color) = - Secure.loggedAction (\_ -> do - updated <- liftIO . Query.run $ CategoryPersistence.edit categoryId name color - if updated - then status ok200 - else status badRequest400 +create :: CreateCategoryForm -> ActionM () +create form = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ do + case CategoryValidation.createCategory form of + Success (CreateCategory name color) -> do + Right <$> (CategoryPersistence.create name color) + + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.okOrBadRequest + ) + +edit :: EditCategoryForm -> ActionM () +edit form = + Secure.loggedAction (\_ -> + (liftIO . Query.run $ do + case CategoryValidation.editCategory form of + Success (EditCategory categoryId name color) -> + do + isSuccess <- CategoryPersistence.edit categoryId name color + return $ if isSuccess then + Right () + else + Left $ Msg.get Msg.Error_CategoryEdit + + Failure validationError -> + return $ Left validationError + ) >>= ControllerHelper.okOrBadRequest ) delete :: CategoryId -> ActionM () diff --git a/server/src/Controller/Helper.hs b/server/src/Controller/Helper.hs index fd0d2bb..dc9cbc4 100644 --- a/server/src/Controller/Helper.hs +++ b/server/src/Controller/Helper.hs @@ -1,17 +1,16 @@ module Controller.Helper - ( jsonOrBadRequest + ( okOrBadRequest ) where -import Data.Aeson (ToJSON) import Data.Text (Text) import qualified Data.Text.Lazy as LT import qualified Network.HTTP.Types.Status as Status import Web.Scotty (ActionM) import qualified Web.Scotty as S -jsonOrBadRequest :: forall a. (ToJSON a) => Either Text a -> ActionM () -jsonOrBadRequest (Left message) = do +okOrBadRequest :: Either Text () -> ActionM () +okOrBadRequest (Left message) = do S.status Status.badRequest400 S.text (LT.fromStrict message) -jsonOrBadRequest (Right a) = - S.json a +okOrBadRequest (Right ()) = + S.status Status.ok200 diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs index 784a2db..96ccbbc 100644 --- a/server/src/Controller/Income.hs +++ b/server/src/Controller/Income.hs @@ -8,7 +8,7 @@ module Controller.Income import Control.Monad.IO.Class (liftIO) import qualified Data.Map as M import qualified Data.Time.Clock as Clock -import Data.Validation (Validation (Failure, Success)) +import Data.Validation (Validation (..)) import qualified Network.HTTP.Types.Status as Status import Web.Scotty hiding (delete) @@ -16,6 +16,7 @@ import Common.Model (CreateIncomeForm (..), EditIncomeForm (..), IncomeHeader (..), IncomeId, IncomePage (..), User (..)) +import qualified Common.Msg as Msg import qualified Controller.Helper as ControllerHelper import Model.CreateIncome (CreateIncome (..)) @@ -60,7 +61,7 @@ create form = Failure validationError -> return $ Left validationError - ) >>= ControllerHelper.jsonOrBadRequest + ) >>= ControllerHelper.okOrBadRequest ) edit :: EditIncomeForm -> ActionM () @@ -68,12 +69,17 @@ edit form = Secure.loggedAction (\user -> (liftIO . Query.run $ do case IncomeValidation.editIncome form of - Success (EditIncome incomeId amount date) -> do - Right <$> (IncomePersistence.edit (_user_id user) incomeId date amount) + Success (EditIncome incomeId amount date) -> + do + isSuccess <- IncomePersistence.edit (_user_id user) incomeId date amount + return $ if isSuccess then + Right () + else + Left $ Msg.get Msg.Error_IncomeEdit Failure validationError -> return $ Left validationError - ) >>= ControllerHelper.jsonOrBadRequest + ) >>= ControllerHelper.okOrBadRequest ) delete :: IncomeId -> ActionM () diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index 42a4436..d6aa34f 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -8,7 +8,6 @@ module Controller.Payment import Control.Monad.IO.Class (liftIO) import qualified Data.Map as M -import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Time.Calendar as Calendar import Data.Validation (Validation (Failure, Success)) @@ -77,30 +76,30 @@ create :: CreatePaymentForm -> ActionM () create form = Secure.loggedAction (\user -> (liftIO . Query.run $ do - cs <- map _category_id <$> CategoryPersistence.list + cs <- map _category_id <$> CategoryPersistence.listAll case PaymentValidation.createPayment cs form of Success (CreatePayment name cost date category frequency) -> Right <$> PaymentPersistence.create (_user_id user) name cost date category frequency Failure validationError -> return $ Left validationError - ) >>= ControllerHelper.jsonOrBadRequest + ) >>= ControllerHelper.okOrBadRequest ) edit :: EditPaymentForm -> ActionM () edit form = Secure.loggedAction (\user -> (liftIO . Query.run $ do - cs <- map _category_id <$> CategoryPersistence.list + cs <- map _category_id <$> CategoryPersistence.listAll case PaymentValidation.editPayment cs form of Success (EditPayment paymentId name cost date category frequency) -> do - editedPayment <- PaymentPersistence.edit (_user_id user) paymentId name cost date category frequency - if Maybe.isJust editedPayment then - return . Right $ editedPayment + isSuccess <- PaymentPersistence.edit (_user_id user) paymentId name cost date category frequency + return $ if isSuccess then + Right () else - return . Left $ Msg.get Msg.Error_PaymentEdit + Left $ Msg.get Msg.Error_PaymentEdit Failure validationError -> return $ Left validationError - ) >>= ControllerHelper.jsonOrBadRequest + ) >>= ControllerHelper.okOrBadRequest ) delete :: PaymentId -> ActionM () -- cgit v1.2.3 From da2a0c13aa89705c65fdb9df2f496fb4eea29654 Mon Sep 17 00:00:00 2001 From: Joris Date: Sat, 4 Jan 2020 19:22:45 +0100 Subject: Allow to remove only unused categories --- server/src/Controller/Category.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'server/src/Controller') diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs index 36ce3fc..371ba78 100644 --- a/server/src/Controller/Category.hs +++ b/server/src/Controller/Category.hs @@ -22,6 +22,7 @@ import Model.CreateCategory (CreateCategory (..)) import Model.EditCategory (EditCategory (..)) import qualified Model.Query as Query import qualified Persistence.Category as CategoryPersistence +import qualified Persistence.Payment as PaymentPersistence import qualified Secure import qualified Validation.Category as CategoryValidation @@ -36,8 +37,9 @@ list page perPage = Secure.loggedAction (\_ -> (liftIO . Query.run $ do categories <- CategoryPersistence.list page perPage + usedCategories <- PaymentPersistence.usedCategories count <- CategoryPersistence.count - return $ CategoryPage page categories count + return $ CategoryPage page categories usedCategories count ) >>= json ) @@ -76,7 +78,6 @@ delete :: CategoryId -> ActionM () delete categoryId = Secure.loggedAction (\_ -> do deleted <- liftIO . Query.run $ do - -- TODO: delete only if no payment has this category CategoryPersistence.delete categoryId if deleted then -- cgit v1.2.3 From af8353c6164aaaaa836bfed181f883ac86bb76a5 Mon Sep 17 00:00:00 2001 From: Joris Date: Sun, 19 Jan 2020 14:03:31 +0100 Subject: Sign in with email and password --- server/src/Controller/Index.hs | 128 ++++++++++++++--------------------------- 1 file changed, 42 insertions(+), 86 deletions(-) (limited to 'server/src/Controller') diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs index 3788685..4f4ae77 100644 --- a/server/src/Controller/Index.hs +++ b/server/src/Controller/Index.hs @@ -1,120 +1,76 @@ module Controller.Index ( get - , askSignIn - , trySignIn + , signIn , signOut ) where import Control.Monad.IO.Class (liftIO) -import qualified Data.Aeson as Json import Data.Text (Text) -import qualified Data.Text as T import qualified Data.Text.Lazy as TL -import Data.Time.Clock (diffUTCTime, getCurrentTime) +import Data.Validation (Validation (..)) import qualified Network.HTTP.Types.Status as Status -import Prelude hiding (error) +import Prelude hiding (error, init) import Web.Scotty (ActionM) import qualified Web.Scotty as S -import Common.Model (Email (..), Init (..), - InitResult (..), SignInForm (..), +import Common.Model (Init (..), SignInForm (..), User (..)) -import Common.Msg (Key) import qualified Common.Msg as Msg -import qualified Common.Validation.SignIn as SignInValidation import Conf (Conf (..)) import qualified LoginSession +import Model.Query (Query) import qualified Model.Query as Query -import qualified Model.SignIn as SignIn +import Model.SignIn (SignIn (..)) import qualified Persistence.User as UserPersistence -import qualified Secure -import qualified SendMail -import qualified View.Mail.SignIn as SignIn +import qualified Validation.SignIn as SignInValidation import View.Page (page) get :: Conf -> ActionM () get conf = do - initResult <- do - mbLoggedUser <- getLoggedUser - case mbLoggedUser of + init <- do + mbToken <- LoginSession.get + case mbToken of Nothing -> - return InitEmpty - Just user -> do - users <- liftIO . Query.run $ UserPersistence.list - return . InitSuccess $ Init users (_user_id user) (Conf.currency conf) - S.html $ page initResult + return Nothing + Just token -> do + liftIO . Query.run $ getInit conf token + S.html $ page init -askSignIn :: Conf -> SignInForm -> ActionM () -askSignIn conf form = +signIn :: Conf -> SignInForm -> ActionM () +signIn conf form = case SignInValidation.signIn form of - Nothing -> - textKey Status.badRequest400 Msg.SignIn_EmailInvalid - Just (Email email) -> do - maybeUser <- liftIO . Query.run $ UserPersistence.get email - case maybeUser of - Just user -> do - token <- liftIO . Query.run $ SignIn.createSignInToken email - let url = T.concat [ - if Conf.https conf then "https://" else "http://", - Conf.hostname conf, - "/api/signIn/", - token - ] - maybeSentMail <- liftIO . SendMail.sendMail conf $ SignIn.mail conf user url [email] - case maybeSentMail of - Right _ -> S.json (Json.String . Msg.get $ Msg.SignIn_EmailSent) - Left _ -> textKey Status.badRequest400 Msg.SignIn_EmailSendFail - Nothing -> textKey Status.badRequest400 Msg.Secure_Unauthorized - where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key) + Failure _ -> + textKey Status.badRequest400 Msg.SignIn_InvalidCredentials + Success (SignIn email password) -> do + result <- liftIO . Query.run $ do + isPasswordValid <- UserPersistence.checkPassword email password + if isPasswordValid then + do + signInToken <- UserPersistence.createSignInToken email + init <- getInit conf signInToken + return $ Just (signInToken, init) + else + return Nothing + case result of + Just (signInToken, init) -> do + LoginSession.put conf signInToken + S.json init -trySignIn :: Conf -> Text -> ActionM () -trySignIn conf token = do - userOrError <- validateSignIn conf token - case userOrError of - Left errorKey -> - S.html $ page (InitError $ Msg.get errorKey) - Right _ -> - S.redirect "/" - -validateSignIn :: Conf -> Text -> ActionM (Either Key User) -validateSignIn conf textToken = do - mbLoggedUser <- getLoggedUser - case mbLoggedUser of - Just loggedUser -> - return . Right $ loggedUser - Nothing -> do - mbSignIn <- liftIO . Query.run $ SignIn.getSignIn textToken - now <- liftIO getCurrentTime - case mbSignIn of Nothing -> - return . Left $ Msg.SignIn_LinkInvalid - Just signIn -> - if SignIn.isUsed signIn - then - return . Left $ Msg.SignIn_LinkUsed - else - let diffTime = now `diffUTCTime` (SignIn.creation signIn) - in if diffTime > signInExpiration conf - then - return . Left $ Msg.SignIn_LinkExpired - else do - LoginSession.put conf (SignIn.token signIn) - mbUser <- liftIO . Query.run $ do - SignIn.signInTokenToUsed . SignIn.id $ signIn - UserPersistence.get . SignIn.email $ signIn - return $ case mbUser of - Nothing -> Left Msg.Secure_Unauthorized - Just user -> Right user + textKey Status.badRequest400 Msg.SignIn_InvalidCredentials + where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key) -getLoggedUser :: ActionM (Maybe User) -getLoggedUser = do - mbToken <- LoginSession.get - case mbToken of +getInit :: Conf -> Text -> Query (Maybe Init) +getInit conf signInToken = do + user <- UserPersistence.get signInToken + case user of + Just u -> + do + users <- UserPersistence.list + return . Just $ Init users (_user_id u) (Conf.currency conf) Nothing -> return Nothing - Just token -> do - liftIO . Query.run . Secure.getUserFromToken $ token signOut :: Conf -> ActionM () signOut conf = LoginSession.delete conf >> S.status Status.ok200 -- cgit v1.2.3 From 47c2a4d6b68c54eed5f7b45671b1ccaf8c0db200 Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 20 Jan 2020 19:47:23 +0100 Subject: Show payment stats --- server/src/Controller/Payment.hs | 9 +++++++++ 1 file changed, 9 insertions(+) (limited to 'server/src/Controller') diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index d6aa34f..80c717f 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -4,6 +4,7 @@ module Controller.Payment , edit , delete , searchCategory + , statistics ) where import Control.Monad.IO.Class (liftIO) @@ -30,6 +31,7 @@ import qualified Persistence.Income as IncomePersistence import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.User as UserPersistence import qualified Secure +import qualified Statistics import qualified Validation.Payment as PaymentValidation list :: Frequency -> Int -> Int -> Text -> ActionM () @@ -114,3 +116,10 @@ searchCategory paymentName = (liftIO $ Query.run (PaymentPersistence.searchCategory paymentName)) >>= S.json ) + +statistics :: ActionM () +statistics = + Secure.loggedAction (\_ -> do + payments <- liftIO $ Query.run PaymentPersistence.listAllPunctual + S.json (Statistics.compute payments) + ) -- cgit v1.2.3 From 79e1d8b0099d61b580a499311f1714b1b7eb07b5 Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 27 Jan 2020 22:07:18 +0100 Subject: Show total incom by month in statistics --- server/src/Controller/Payment.hs | 9 --------- server/src/Controller/Statistics.hs | 21 +++++++++++++++++++++ 2 files changed, 21 insertions(+), 9 deletions(-) create mode 100644 server/src/Controller/Statistics.hs (limited to 'server/src/Controller') diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs index 80c717f..d6aa34f 100644 --- a/server/src/Controller/Payment.hs +++ b/server/src/Controller/Payment.hs @@ -4,7 +4,6 @@ module Controller.Payment , edit , delete , searchCategory - , statistics ) where import Control.Monad.IO.Class (liftIO) @@ -31,7 +30,6 @@ import qualified Persistence.Income as IncomePersistence import qualified Persistence.Payment as PaymentPersistence import qualified Persistence.User as UserPersistence import qualified Secure -import qualified Statistics import qualified Validation.Payment as PaymentValidation list :: Frequency -> Int -> Int -> Text -> ActionM () @@ -116,10 +114,3 @@ searchCategory paymentName = (liftIO $ Query.run (PaymentPersistence.searchCategory paymentName)) >>= S.json ) - -statistics :: ActionM () -statistics = - Secure.loggedAction (\_ -> do - payments <- liftIO $ Query.run PaymentPersistence.listAllPunctual - S.json (Statistics.compute payments) - ) diff --git a/server/src/Controller/Statistics.hs b/server/src/Controller/Statistics.hs new file mode 100644 index 0000000..500c93c --- /dev/null +++ b/server/src/Controller/Statistics.hs @@ -0,0 +1,21 @@ +module Controller.Statistics + ( paymentsAndIncomes + ) where + +import Control.Monad.IO.Class (liftIO) +import Web.Scotty (ActionM) +import qualified Web.Scotty as S + +import qualified Model.Query as Query +import qualified Persistence.Income as IncomePersistence +import qualified Persistence.Payment as PaymentPersistence +import qualified Secure +import qualified Statistics + +paymentsAndIncomes :: ActionM () +paymentsAndIncomes = + Secure.loggedAction (\_ -> do + payments <- liftIO $ Query.run PaymentPersistence.listAllPunctual + incomes <- liftIO $ Query.run IncomePersistence.listAll + S.json (Statistics.paymentsAndIncomes payments incomes) + ) -- cgit v1.2.3