aboutsummaryrefslogtreecommitdiff
path: root/server/src/Controller
diff options
context:
space:
mode:
Diffstat (limited to 'server/src/Controller')
-rw-r--r--server/src/Controller/Category.hs53
-rw-r--r--server/src/Controller/Income.hs48
-rw-r--r--server/src/Controller/Index.hs86
-rw-r--r--server/src/Controller/Payment.hs58
-rw-r--r--server/src/Controller/SignIn.hs47
5 files changed, 292 insertions, 0 deletions
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)
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-23 02:19:23 +0000