aboutsummaryrefslogtreecommitdiff
path: root/src/server
diff options
context:
space:
mode:
Diffstat (limited to 'src/server')
-rw-r--r--src/server/Controller/Index.hs38
-rw-r--r--src/server/Controller/User.hs25
-rw-r--r--src/server/Main.hs23
-rw-r--r--src/server/Model/Json/Payment.hs6
-rw-r--r--src/server/Model/Json/TotalPayment.hs4
-rw-r--r--src/server/Model/Json/User.hs21
-rw-r--r--src/server/Model/Payment.hs15
-rw-r--r--src/server/Model/User.hs11
8 files changed, 76 insertions, 67 deletions
diff --git a/src/server/Controller/Index.hs b/src/server/Controller/Index.hs
index 2d8c40c..17f5ae9 100644
--- a/src/server/Controller/Index.hs
+++ b/src/server/Controller/Index.hs
@@ -1,58 +1,20 @@
module Controller.Index
( getIndexAction
- , getUserName
, signOutAction
- , getUsersAction
- , addUserAction
- , deleteUserAction
) where
import Web.Scotty
import Network.HTTP.Types.Status (ok200)
-import Database.Persist
-
-import Control.Monad.IO.Class (liftIO)
-
-import Data.Text (Text)
-import Data.String (fromString)
-
import qualified LoginSession
-import qualified Secure
-
-import Model.Database
-import Model.User
-import Model.Json.Message
-
import View.Page (page)
getIndexAction :: ActionM ()
getIndexAction = html page
-getUserName :: ActionM ()
-getUserName =
- Secure.loggedAction (\user -> do
- json . Message . userName . entityVal $ user
- )
-
signOutAction :: ActionM ()
signOutAction = do
LoginSession.delete
status ok200
-
-getUsersAction :: ActionM ()
-getUsersAction = do
- users <- liftIO $ runDb getUsers
- html . fromString . show $ users
-
-addUserAction :: Text -> Text -> ActionM ()
-addUserAction email name = do
- _ <- liftIO . runDb $ createUser email name
- status ok200
-
-deleteUserAction :: Text -> ActionM ()
-deleteUserAction email = do
- _ <- liftIO . runDb $ deleteUser email
- status ok200
diff --git a/src/server/Controller/User.hs b/src/server/Controller/User.hs
new file mode 100644
index 0000000..95e5fa8
--- /dev/null
+++ b/src/server/Controller/User.hs
@@ -0,0 +1,25 @@
+module Controller.User
+ ( getUsersAction
+ , whoAmIAction
+ ) where
+
+import Web.Scotty
+
+import Control.Monad.IO.Class (liftIO)
+
+import qualified Secure
+
+import Model.Database
+import Model.User
+
+getUsersAction :: ActionM ()
+getUsersAction =
+ Secure.loggedAction (\_ -> do
+ (liftIO $ map getJsonUser <$> runDb getUsers) >>= json
+ )
+
+whoAmIAction :: ActionM ()
+whoAmIAction =
+ Secure.loggedAction (\user -> do
+ json (getJsonUser user)
+ )
diff --git a/src/server/Main.hs b/src/server/Main.hs
index 8a77598..27908b4 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -10,6 +10,7 @@ import qualified Data.Text.IO as TIO
import Controller.Index
import Controller.SignIn
import Controller.Payment
+import Controller.User
import Model.Database (runMigrations)
@@ -39,8 +40,14 @@ main = do
token <- param "token" :: ActionM Text
validateSignInAction config token
- get "/userName" $
- getUserName
+ post "/signOut" $
+ signOutAction
+
+ get "/whoAmI" $
+ whoAmIAction
+
+ get "/users" $ do
+ getUsersAction
get "/payments" $ do
page <- param "page" :: ActionM Int
@@ -61,15 +68,3 @@ main = do
get "/payments/count" $ do
getPaymentsCountAction
-
- post "/signOut" $
- signOutAction
-
- get "/users" getUsersAction
- post "/user/add" $ do
- email <- param "email" :: ActionM Text
- name <- param "name" :: ActionM Text
- addUserAction email name
- post "/user/delete" $ do
- email <- param "email" :: ActionM Text
- deleteUserAction email
diff --git a/src/server/Model/Json/Payment.hs b/src/server/Model/Json/Payment.hs
index f22c8cf..8923c13 100644
--- a/src/server/Model/Json/Payment.hs
+++ b/src/server/Model/Json/Payment.hs
@@ -10,12 +10,14 @@ import Data.Time
import Data.Text (Text)
import Data.Aeson
+import Model.Database (PaymentId, UserId)
+
data Payment = Payment
- { id :: Text
+ { id :: PaymentId
, creation :: UTCTime
, name :: Text
, cost :: Int
- , userName :: Text
+ , userId :: UserId
} deriving (Show, Generic)
instance FromJSON Payment
diff --git a/src/server/Model/Json/TotalPayment.hs b/src/server/Model/Json/TotalPayment.hs
index e386c79..5ae68c9 100644
--- a/src/server/Model/Json/TotalPayment.hs
+++ b/src/server/Model/Json/TotalPayment.hs
@@ -9,8 +9,10 @@ import GHC.Generics
import Data.Text (Text)
import Data.Aeson
+import Model.Database (UserId)
+
data TotalPayment = TotalPayment
- { userName :: Text
+ { userId :: UserId
, totalPayment :: Int
} deriving (Show, Generic)
diff --git a/src/server/Model/Json/User.hs b/src/server/Model/Json/User.hs
new file mode 100644
index 0000000..ebc347b
--- /dev/null
+++ b/src/server/Model/Json/User.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Model.Json.User
+ ( User(..)
+ ) where
+
+import GHC.Generics
+
+import Data.Aeson
+import Data.Text (Text)
+
+import Model.Database (UserId)
+
+data User = User
+ { id :: UserId
+ , name :: Text
+ , email :: Text
+ } deriving (Show, Generic)
+
+instance FromJSON User
+instance ToJSON User
diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs
index ce8c5a1..d7632f0 100644
--- a/src/server/Model/Payment.hs
+++ b/src/server/Model/Payment.hs
@@ -1,14 +1,12 @@
module Model.Payment
( getPayments
, createPayment
- , paymentKeyToText
, deleteOwnPayment
, getTotalPayments
, getPaymentsCount
) where
import Data.Text (Text)
-import qualified Data.Text as T
import Data.Time.Clock (getCurrentTime)
import Data.Maybe (catMaybes)
@@ -40,16 +38,13 @@ getJsonPayment (paymentEntity, userEntity) =
let payment = entityVal paymentEntity
user = entityVal userEntity
in P.Payment
- { P.id = paymentKeyToText . entityKey $ paymentEntity
+ { P.id = entityKey paymentEntity
, P.creation = paymentCreation payment
, P.name = paymentName payment
, P.cost = paymentCost payment
- , P.userName = userName user
+ , P.userId = entityKey userEntity
}
-paymentKeyToText :: Key Payment -> Text
-paymentKeyToText = T.pack . show . unSqlBackendKey . unPaymentKey
-
createPayment :: UserId -> Text -> Int -> Persist PaymentId
createPayment userId name cost = do
now <- liftIO getCurrentTime
@@ -77,11 +72,11 @@ getTotalPayments = do
on (payment ^. PaymentUserId E.==. user ^. UserId)
where_ (isNothing (payment ^. PaymentDeletedAt))
groupBy (payment ^. PaymentUserId)
- return (user ^. UserName, sum_ (payment ^. PaymentCost))
+ return (user ^. UserId, sum_ (payment ^. PaymentCost))
return $ catMaybes . map (getTotalPayment . unValueTuple) $ values
-getTotalPayment :: (Text, Maybe Int) -> Maybe TP.TotalPayment
-getTotalPayment (userName, Just cost) = Just (TP.TotalPayment userName cost)
+getTotalPayment :: (UserId, Maybe Int) -> Maybe TP.TotalPayment
+getTotalPayment (userId, Just cost) = Just (TP.TotalPayment userId cost)
getTotalPayment (_, Nothing) = Nothing
unValueTuple :: (Value a, Value b) -> (a, b)
diff --git a/src/server/Model/User.hs b/src/server/Model/User.hs
index 339aff6..2b52d03 100644
--- a/src/server/Model/User.hs
+++ b/src/server/Model/User.hs
@@ -1,6 +1,7 @@
module Model.User
( getUsers
, getUser
+ , getJsonUser
, createUser
, deleteUser
) where
@@ -13,13 +14,19 @@ import Control.Monad.IO.Class (liftIO)
import Database.Persist
import Model.Database
+import qualified Model.Json.User as Json
-getUsers :: Persist [User]
-getUsers = map entityVal <$> selectList [] [Desc UserCreation]
+getUsers :: Persist [Entity User]
+getUsers = selectList [] [Desc UserCreation]
getUser :: Text -> Persist (Maybe (Entity User))
getUser email = selectFirst [UserEmail ==. email] []
+getJsonUser :: Entity User -> Json.User
+getJsonUser userEntity =
+ let user = entityVal userEntity
+ in Json.User (entityKey userEntity) (userName user) (userEmail user)
+
createUser :: Text -> Text -> Persist UserId
createUser email name = do
now <- liftIO getCurrentTime
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 21:35:12 +0000