Use a better project structure

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)