aboutsummaryrefslogtreecommitdiff
path: root/server/src/Controller
diff options
context:
space:
mode:
Diffstat (limited to 'server/src/Controller')
-rw-r--r--server/src/Controller/Category.hs88
-rw-r--r--server/src/Controller/Helper.hs16
-rw-r--r--server/src/Controller/Income.hs90
-rw-r--r--server/src/Controller/Index.hs76
-rw-r--r--server/src/Controller/Payment.hs116
-rw-r--r--server/src/Controller/Statistics.hs21
-rw-r--r--server/src/Controller/User.hs17
7 files changed, 424 insertions, 0 deletions
diff --git a/server/src/Controller/Category.hs b/server/src/Controller/Category.hs
new file mode 100644
index 0000000..371ba78
--- /dev/null
+++ b/server/src/Controller/Category.hs
@@ -0,0 +1,88 @@
+module Controller.Category
+ ( listAll
+ , list
+ , create
+ , edit
+ , delete
+ ) where
+
+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, CategoryPage (..),
+ CreateCategoryForm (..),
+ EditCategoryForm (..))
+import qualified Common.Msg as Msg
+
+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 Persistence.Payment as PaymentPersistence
+import qualified Secure
+import qualified Validation.Category as CategoryValidation
+
+listAll :: ActionM ()
+listAll =
+ Secure.loggedAction (\_ ->
+ (liftIO . Query.run $ CategoryPersistence.listAll) >>= json
+ )
+
+list :: Int -> Int -> ActionM ()
+list page perPage =
+ Secure.loggedAction (\_ ->
+ (liftIO . Query.run $ do
+ categories <- CategoryPersistence.list page perPage
+ usedCategories <- PaymentPersistence.usedCategories
+ count <- CategoryPersistence.count
+ return $ CategoryPage page categories usedCategories count
+ ) >>= json
+ )
+
+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 ()
+delete categoryId =
+ Secure.loggedAction (\_ -> do
+ deleted <- liftIO . Query.run $ do
+ CategoryPersistence.delete categoryId
+ if deleted
+ then
+ status ok200
+ else do
+ status badRequest400
+ text . TL.fromStrict $ Msg.get Msg.Category_NotDeleted
+ )
diff --git a/server/src/Controller/Helper.hs b/server/src/Controller/Helper.hs
new file mode 100644
index 0000000..dc9cbc4
--- /dev/null
+++ b/server/src/Controller/Helper.hs
@@ -0,0 +1,16 @@
+module Controller.Helper
+ ( okOrBadRequest
+ ) where
+
+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
+
+okOrBadRequest :: Either Text () -> ActionM ()
+okOrBadRequest (Left message) = do
+ S.status Status.badRequest400
+ S.text (LT.fromStrict message)
+okOrBadRequest (Right ()) =
+ S.status Status.ok200
diff --git a/server/src/Controller/Income.hs b/server/src/Controller/Income.hs
new file mode 100644
index 0000000..96ccbbc
--- /dev/null
+++ b/server/src/Controller/Income.hs
@@ -0,0 +1,90 @@
+module Controller.Income
+ ( list
+ , 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 (..))
+import qualified Network.HTTP.Types.Status as Status
+import Web.Scotty hiding (delete)
+
+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 (..))
+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 :: Int -> Int -> ActionM ()
+list page perPage =
+ Secure.loggedAction (\_ -> do
+ currentTime <- liftIO Clock.getCurrentTime
+ (liftIO . Query.run $ do
+ count <- IncomePersistence.count
+
+ users <- UserPersistence.list
+ let userIds = _user_id <$> users
+
+ paymentRange <- PaymentPersistence.getRange
+ incomeDefinedForAll <- IncomePersistence.definedForAll userIds
+ let since = max <$> (fst <$> paymentRange) <*> incomeDefinedForAll
+
+ cumulativeIncome <-
+ case since of
+ Just s -> IncomePersistence.getCumulativeIncome s (Clock.utctDay currentTime)
+ Nothing -> return M.empty
+
+ incomes <- IncomePersistence.list page perPage
+ return $ IncomePage page (IncomeHeader since cumulativeIncome) incomes count) >>= json
+ )
+
+create :: CreateIncomeForm -> ActionM ()
+create form =
+ Secure.loggedAction (\user ->
+ (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.okOrBadRequest
+ )
+
+edit :: EditIncomeForm -> ActionM ()
+edit form =
+ Secure.loggedAction (\user ->
+ (liftIO . Query.run $ do
+ case IncomeValidation.editIncome form of
+ 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.okOrBadRequest
+ )
+
+delete :: IncomeId -> ActionM ()
+delete incomeId =
+ Secure.loggedAction (\user -> do
+ _ <- liftIO . Query.run $ IncomePersistence.delete (_user_id user) incomeId
+ status Status.ok200
+ )
diff --git a/server/src/Controller/Index.hs b/server/src/Controller/Index.hs
new file mode 100644
index 0000000..4f4ae77
--- /dev/null
+++ b/server/src/Controller/Index.hs
@@ -0,0 +1,76 @@
+module Controller.Index
+ ( get
+ , signIn
+ , signOut
+ ) where
+
+import Control.Monad.IO.Class (liftIO)
+import Data.Text (Text)
+import qualified Data.Text.Lazy as TL
+import Data.Validation (Validation (..))
+import qualified Network.HTTP.Types.Status as Status
+import Prelude hiding (error, init)
+import Web.Scotty (ActionM)
+import qualified Web.Scotty as S
+
+import Common.Model (Init (..), SignInForm (..),
+ User (..))
+import qualified Common.Msg as Msg
+
+import Conf (Conf (..))
+import qualified LoginSession
+import Model.Query (Query)
+import qualified Model.Query as Query
+import Model.SignIn (SignIn (..))
+import qualified Persistence.User as UserPersistence
+import qualified Validation.SignIn as SignInValidation
+import View.Page (page)
+
+get :: Conf -> ActionM ()
+get conf = do
+ init <- do
+ mbToken <- LoginSession.get
+ case mbToken of
+ Nothing ->
+ return Nothing
+ Just token -> do
+ liftIO . Query.run $ getInit conf token
+ S.html $ page init
+
+signIn :: Conf -> SignInForm -> ActionM ()
+signIn conf form =
+ case SignInValidation.signIn form of
+ 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
+
+ Nothing ->
+ textKey Status.badRequest400 Msg.SignIn_InvalidCredentials
+ where textKey st key = S.status st >> (S.text . TL.fromStrict $ Msg.get key)
+
+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
+
+signOut :: Conf -> ActionM ()
+signOut conf = LoginSession.delete conf >> S.status Status.ok200
diff --git a/server/src/Controller/Payment.hs b/server/src/Controller/Payment.hs
new file mode 100644
index 0000000..d6aa34f
--- /dev/null
+++ b/server/src/Controller/Payment.hs
@@ -0,0 +1,116 @@
+module Controller.Payment
+ ( list
+ , create
+ , edit
+ , delete
+ , searchCategory
+ ) where
+
+import Control.Monad.IO.Class (liftIO)
+import qualified Data.Map as M
+import Data.Text (Text)
+import qualified Data.Time.Calendar as Calendar
+import Data.Validation (Validation (Failure, Success))
+import Web.Scotty (ActionM)
+import qualified Web.Scotty as S
+
+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 Validation.Payment as PaymentValidation
+
+list :: Frequency -> Int -> Int -> Text -> ActionM ()
+list frequency page perPage search =
+ Secure.loggedAction (\_ ->
+ (liftIO . Query.run $ do
+ count <- PaymentPersistence.count frequency search
+ payments <- PaymentPersistence.listActivePage frequency page perPage search
+
+ users <- UserPersistence.list
+
+ 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
+ Just (from, to) ->
+ PaymentPersistence.repartition frequency search from (Calendar.addDays 1 to)
+ Nothing ->
+ return M.empty
+
+ (preIncomeRepartition, postIncomeRepartition) <-
+ PaymentPersistence.getPreAndPostPaymentRepartition paymentRange users
+
+ let exceedingPayers = Payer.getExceedingPayers users cumulativeIncome preIncomeRepartition postIncomeRepartition
+
+ header = PaymentHeader
+ { _paymentHeader_exceedingPayers = exceedingPayers
+ , _paymentHeader_repartition = searchRepartition
+ }
+
+ return $ PaymentPage page frequency header payments count) >>= S.json
+ )
+
+create :: CreatePaymentForm -> ActionM ()
+create form =
+ Secure.loggedAction (\user ->
+ (liftIO . Query.run $ do
+ 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.okOrBadRequest
+ )
+
+edit :: EditPaymentForm -> ActionM ()
+edit form =
+ Secure.loggedAction (\user ->
+ (liftIO . Query.run $ do
+ cs <- map _category_id <$> CategoryPersistence.listAll
+ case PaymentValidation.editPayment cs form of
+ Success (EditPayment paymentId name cost date category frequency) -> do
+ isSuccess <- PaymentPersistence.edit (_user_id user) paymentId name cost date category frequency
+ return $ if isSuccess then
+ Right ()
+ else
+ Left $ Msg.get Msg.Error_PaymentEdit
+ Failure validationError ->
+ return $ Left validationError
+ ) >>= ControllerHelper.okOrBadRequest
+ )
+
+delete :: PaymentId -> ActionM ()
+delete paymentId =
+ 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
+ )
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)
+ )
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
+ )
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-23 09:02:11 +0000