aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/client/Main.elm10
-rw-r--r--src/client/Model/Payers.elm18
-rw-r--r--src/client/Model/Payment.elm12
-rw-r--r--src/client/Model/User.elm42
-rw-r--r--src/client/Model/View/PaymentView.elm11
-rw-r--r--src/client/ServerCommunication.elm17
-rw-r--r--src/client/Update.elm7
-rw-r--r--src/client/Update/Payment.elm13
-rw-r--r--src/client/View/Payments/Add.elm2
-rw-r--r--src/client/View/Payments/ExceedingPayer.elm19
-rw-r--r--src/client/View/Payments/Table.elm13
-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
19 files changed, 194 insertions, 113 deletions
diff --git a/src/client/Main.elm b/src/client/Main.elm
index 685d3b2..07f8294 100644
--- a/src/client/Main.elm
+++ b/src/client/Main.elm
@@ -12,6 +12,7 @@ import Time exposing (..)
import Json.Decode as Json exposing ((:=))
import Model exposing (Model, initialModel)
+import Model.User exposing (Users, usersDecoder, UserId, userIdDecoder)
import Model.Payment exposing (Payments, paymentsDecoder, perPage)
import Model.Payers exposing (Payers, payersDecoder)
import Model.Message exposing (messageDecoder)
@@ -56,12 +57,15 @@ port initView =
Just msg ->
Signal.send actions.address (SignInError msg)
Nothing ->
- Task.map4 GoPaymentView getUserName getPayments getPaymentsCount getPayers
+ Task.map5 GoPaymentView getUsers whoAmI getPayments getPaymentsCount getPayers
|> flip Task.andThen (Signal.send actions.address)
|> flip Task.onError (\_ -> Signal.send actions.address GoSignInView)
-getUserName : Task Http.Error String
-getUserName = Http.get messageDecoder "/userName"
+getUsers : Task Http.Error Users
+getUsers = Http.get usersDecoder "/users"
+
+whoAmI : Task Http.Error UserId
+whoAmI = Http.get ("id" := userIdDecoder) "/whoAmI"
getPayments : Task Http.Error Payments
getPayments = Http.get paymentsDecoder ("/payments?page=1&perPage=" ++ toString perPage)
diff --git a/src/client/Model/Payers.elm b/src/client/Model/Payers.elm
index 6550eaa..983e7b3 100644
--- a/src/client/Model/Payers.elm
+++ b/src/client/Model/Payers.elm
@@ -11,21 +11,23 @@ import Dict exposing (..)
import List
import Maybe
-type alias Payers = Dict String Int
+import Model.User exposing (UserId, userIdDecoder)
+
+type alias Payers = Dict UserId Int
payersDecoder : Decoder Payers
payersDecoder = Json.map Dict.fromList (list payerDecoder)
-payerDecoder : Decoder (String, Int)
+payerDecoder : Decoder (UserId, Int)
payerDecoder =
object2 (,)
- ("userName" := string)
+ ("userId" := userIdDecoder)
("totalPayment" := int)
-updatePayers : Payers -> String -> Int -> Payers
-updatePayers payers userName amountDiff =
+updatePayers : Payers -> UserId -> Int -> Payers
+updatePayers payers userId amountDiff =
Dict.update
- userName
+ userId
(\mbAmount ->
case mbAmount of
Just amount -> Just (amount + amountDiff)
@@ -34,7 +36,7 @@ updatePayers payers userName amountDiff =
payers
type alias ExceedingPayer =
- { userName : String
+ { userId : UserId
, amount : Int
}
@@ -42,7 +44,7 @@ getOrderedExceedingPayers : Payers -> List ExceedingPayer
getOrderedExceedingPayers payers =
let orderedPayers =
Dict.toList payers
- |> List.map (\(userName, amount) -> ExceedingPayer userName amount)
+ |> List.map (\(userId, amount) -> ExceedingPayer userId amount)
|> List.sortBy .amount
maybeMinAmount =
List.head orderedPayers
diff --git a/src/client/Model/Payment.elm b/src/client/Model/Payment.elm
index 8a51c66..4ae50de 100644
--- a/src/client/Model/Payment.elm
+++ b/src/client/Model/Payment.elm
@@ -12,6 +12,8 @@ import Date exposing (..)
import Json.Decode as Json exposing ((:=))
import Dict exposing (..)
+import Model.User exposing (UserId, userIdDecoder)
+
perPage : Int
perPage = 8
@@ -23,17 +25,17 @@ type alias Payment =
{ creation : Date
, name : String
, cost : Int
- , userName : String
+ , userId : UserId
}
-type alias PaymentId = String
+type alias PaymentId = Int
paymentsDecoder : Json.Decoder Payments
paymentsDecoder = Json.map Dict.fromList (Json.list paymentWithIdDecoder)
paymentWithIdDecoder : Json.Decoder (PaymentId, Payment)
paymentWithIdDecoder =
- paymentDecoder `Json.andThen` (\payment -> Json.map (\id -> (id, payment)) ("id" := Json.string))
+ paymentDecoder `Json.andThen` (\payment -> Json.map (\id -> (id, payment)) ("id" := paymentIdDecoder))
paymentDecoder : Json.Decoder Payment
paymentDecoder =
@@ -41,10 +43,10 @@ paymentDecoder =
("creation" := dateDecoder)
("name" := Json.string)
("cost" := Json.int)
- ("userName" := Json.string)
+ ("userId" := userIdDecoder)
paymentIdDecoder : Json.Decoder PaymentId
-paymentIdDecoder = Json.string
+paymentIdDecoder = Json.int
dateDecoder : Json.Decoder Date
dateDecoder = Json.customDecoder Json.string Date.fromString
diff --git a/src/client/Model/User.elm b/src/client/Model/User.elm
new file mode 100644
index 0000000..b0d62a6
--- /dev/null
+++ b/src/client/Model/User.elm
@@ -0,0 +1,42 @@
+module Model.User
+ ( Users
+ , usersDecoder
+ , User
+ , userDecoder
+ , UserId
+ , userIdDecoder
+ , getUserName
+ ) where
+
+import Json.Decode as Json exposing ((:=))
+import Dict exposing (Dict)
+
+type alias Users = Dict UserId User
+
+type alias UserId = Int
+
+type alias User =
+ { name : String
+ , email : String
+ }
+
+usersDecoder : Json.Decoder Users
+usersDecoder = Json.map Dict.fromList (Json.list userWithIdDecoder)
+
+userWithIdDecoder : Json.Decoder (UserId, User)
+userWithIdDecoder =
+ userDecoder `Json.andThen` (\user -> Json.map (\id -> (id, user)) ("id" := userIdDecoder))
+
+userDecoder : Json.Decoder User
+userDecoder =
+ Json.object2 User
+ ("name" := Json.string)
+ ("email" := Json.string)
+
+userIdDecoder : Json.Decoder UserId
+userIdDecoder = Json.int
+
+getUserName : Users -> UserId -> Maybe String
+getUserName users userId =
+ Dict.get userId users
+ |> Maybe.map .name
diff --git a/src/client/Model/View/PaymentView.elm b/src/client/Model/View/PaymentView.elm
index bf5804f..93ab457 100644
--- a/src/client/Model/View/PaymentView.elm
+++ b/src/client/Model/View/PaymentView.elm
@@ -3,13 +3,15 @@ module Model.View.PaymentView
, initPaymentView
) where
+import Model.User exposing (Users, UserId)
import Model.Payment exposing (Payments)
import Model.Payers exposing (Payers)
import Model.View.Payment.Add exposing (..)
import Model.View.Payment.Edition exposing (..)
type alias PaymentView =
- { userName : String
+ { users : Users
+ , me : UserId
, add : AddPayment
, payments : Payments
, paymentsCount : Int
@@ -18,9 +20,10 @@ type alias PaymentView =
, currentPage : Int
}
-initPaymentView : String -> Payments -> Int -> Payers -> PaymentView
-initPaymentView userName payments paymentsCount payers =
- { userName = userName
+initPaymentView : Users -> UserId -> Payments -> Int -> Payers -> PaymentView
+initPaymentView users me payments paymentsCount payers =
+ { users = users
+ , me = me
, add = initAddPayment
, payments = payments
, paymentsCount = paymentsCount
diff --git a/src/client/ServerCommunication.elm b/src/client/ServerCommunication.elm
index 719a563..5ddcfb9 100644
--- a/src/client/ServerCommunication.elm
+++ b/src/client/ServerCommunication.elm
@@ -11,6 +11,7 @@ import Json.Decode exposing (..)
import Date
import Model.Message exposing (messageDecoder)
+import Model.User exposing (UserId)
import Model.Payment exposing (PaymentId, perPage, paymentsDecoder)
import Update as U
@@ -20,8 +21,8 @@ import Update.Payment as UP
type Communication =
NoCommunication
| SignIn String
- | AddPayment String String Int
- | DeletePayment PaymentId String Int Int
+ | AddPayment UserId String Int
+ | DeletePayment PaymentId UserId Int Int
| UpdatePage Int
| SignOut
@@ -43,10 +44,10 @@ getRequest communication =
Nothing
SignIn login ->
Just (simple "post" ("/signIn?login=" ++ login))
- AddPayment userName paymentName cost ->
+ AddPayment userId paymentName cost ->
Just (simple "post" ("/payment/add?name=" ++ paymentName ++ "&cost=" ++ (toString cost)))
DeletePayment paymentId _ _ _ ->
- Just (simple "post" ("payment/delete?id=" ++ paymentId))
+ Just (simple "post" ("payment/delete?id=" ++ (toString paymentId)))
UpdatePage page ->
Just (updatePageRequest page)
SignOut ->
@@ -73,7 +74,7 @@ serverResult communication response =
Task.succeed U.NoOp
SignIn login ->
Task.succeed (U.UpdateSignIn (ValidLogin login))
- AddPayment userName paymentName cost ->
+ AddPayment userId paymentName cost ->
Http.send Http.defaultSettings (updatePageRequest 1)
|> Task.map (\response ->
if response.status == 200
@@ -81,11 +82,11 @@ serverResult communication response =
decodeResponse
response
paymentsDecoder
- (\payments -> U.UpdatePayment (UP.AddPayment userName cost payments))
+ (\payments -> U.UpdatePayment (UP.AddPayment userId cost payments))
else
U.NoOp
)
- DeletePayment id userName cost currentPage ->
+ DeletePayment id userId cost currentPage ->
Http.send Http.defaultSettings (updatePageRequest currentPage)
|> Task.map (\response ->
if response.status == 200
@@ -93,7 +94,7 @@ serverResult communication response =
decodeResponse
response
paymentsDecoder
- (\payments -> U.UpdatePayment (UP.Remove userName cost payments))
+ (\payments -> U.UpdatePayment (UP.Remove userId cost payments))
else
U.NoOp
)
diff --git a/src/client/Update.elm b/src/client/Update.elm
index 374c5d0..910f080 100644
--- a/src/client/Update.elm
+++ b/src/client/Update.elm
@@ -7,6 +7,7 @@ module Update
import Time exposing (Time)
import Model exposing (Model)
+import Model.User exposing (Users, UserId)
import Model.Payment exposing (Payments)
import Model.Payers exposing (Payers)
import Model.View as V
@@ -22,7 +23,7 @@ type Action =
| GoSignInView
| SignInError String
| UpdateSignIn SignInAction
- | GoPaymentView String Payments Int Payers
+ | GoPaymentView Users UserId Payments Int Payers
| UpdatePayment PaymentAction
actions : Signal.Mailbox Action
@@ -37,8 +38,8 @@ updateModel action model =
{ model | currentTime <- time }
GoSignInView ->
{ model | view <- V.SignInView initSignInView }
- GoPaymentView userName payments paymentsCount payers ->
- { model | view <- V.PaymentView (initPaymentView userName payments paymentsCount payers) }
+ GoPaymentView users me payments paymentsCount payers ->
+ { model | view <- V.PaymentView (initPaymentView users me payments paymentsCount payers) }
SignInError msg ->
let signInView = { initSignInView | result <- Just (Err msg) }
in { model | view <- V.SignInView signInView }
diff --git a/src/client/Update/Payment.elm b/src/client/Update/Payment.elm
index b9b60dd..1b43f6f 100644
--- a/src/client/Update/Payment.elm
+++ b/src/client/Update/Payment.elm
@@ -7,6 +7,7 @@ import Date
import Dict
import Model exposing (Model)
+import Model.User exposing (UserId)
import Model.Payment exposing (..)
import Model.Payers exposing (..)
import Model.View.PaymentView exposing (..)
@@ -17,9 +18,9 @@ import Update.Payment.Add exposing (..)
type PaymentAction =
UpdateAdd AddPaymentAction
| UpdatePayments Payments
- | AddPayment String Int Payments
+ | AddPayment UserId Int Payments
| ToggleEdit PaymentId
- | Remove String Int Payments
+ | Remove UserId Int Payments
| UpdatePage Int Payments
updatePayment : Model -> PaymentAction -> PaymentView -> PaymentView
@@ -29,20 +30,20 @@ updatePayment model action paymentView =
{ paymentView | add <- updateAddPayment addPaymentAction paymentView.add }
UpdatePayments payments ->
{ paymentView | payments <- payments }
- AddPayment userName cost payments ->
+ AddPayment userId cost payments ->
{ paymentView
| payments <- payments
, currentPage <- 1
, add <- initAddPayment
- , payers <- updatePayers paymentView.payers userName cost
+ , payers <- updatePayers paymentView.payers userId cost
, paymentsCount <- paymentView.paymentsCount + 1
}
ToggleEdit id ->
{ paymentView | edition <- if paymentView.edition == Just id then Nothing else Just id }
- Remove userName cost payments ->
+ Remove userId cost payments ->
{ paymentView
| payments <- payments
- , payers <- updatePayers paymentView.payers userName -cost
+ , payers <- updatePayers paymentView.payers userId -cost
, paymentsCount <- paymentView.paymentsCount - 1
}
UpdatePage page payments ->
diff --git a/src/client/View/Payments/Add.elm b/src/client/View/Payments/Add.elm
index 115fed2..32233ed 100644
--- a/src/client/View/Payments/Add.elm
+++ b/src/client/View/Payments/Add.elm
@@ -31,7 +31,7 @@ addPayment model paymentView =
[ class "add"
, case (validateName paymentView.add.name model.translations, validateCost paymentView.add.cost model.translations) of
(Ok name, Ok cost) ->
- onSubmitPrevDefault serverCommunications.address (SC.AddPayment paymentView.userName name cost)
+ onSubmitPrevDefault serverCommunications.address (SC.AddPayment paymentView.me name cost)
(resName, resCost) ->
onSubmitPrevDefault actions.address (UpdatePayment <| UpdateAdd <| AddError (toMaybeError resName) (toMaybeError resCost))
]
diff --git a/src/client/View/Payments/ExceedingPayer.elm b/src/client/View/Payments/ExceedingPayer.elm
index 903ad5b..f249383 100644
--- a/src/client/View/Payments/ExceedingPayer.elm
+++ b/src/client/View/Payments/ExceedingPayer.elm
@@ -7,6 +7,7 @@ import Html.Attributes exposing (..)
import List
import Model exposing (Model)
+import Model.User exposing (getUserName)
import Model.Payers exposing (..)
import Model.View.PaymentView exposing (PaymentView)
import Model.Translations exposing (getMessage)
@@ -15,12 +16,20 @@ exceedingPayers : Model -> PaymentView -> Html
exceedingPayers model paymentView =
div
[ class "exceedingPayers" ]
- (List.map (exceedingPayer model) (getOrderedExceedingPayers paymentView.payers))
+ (List.map (exceedingPayer model paymentView) (getOrderedExceedingPayers paymentView.payers))
-exceedingPayer : Model -> ExceedingPayer -> Html
-exceedingPayer model payer =
+exceedingPayer : Model -> PaymentView -> ExceedingPayer -> Html
+exceedingPayer model paymentView payer =
div
[ class "exceedingPayer" ]
- [ span [ class "userName" ] [ text payer.userName ]
- , span [ class "amount" ] [ text ("+ " ++ (toString payer.amount) ++ " " ++ (getMessage "MoneySymbol" model.translations)) ]
+ [ span
+ [ class "userName" ]
+ [ payer.userId
+ |> getUserName paymentView.users
+ |> Maybe.withDefault "−"
+ |> text
+ ]
+ , span
+ [ class "amount" ]
+ [ text ("+ " ++ (toString payer.amount) ++ " " ++ (getMessage "MoneySymbol" model.translations)) ]
]
diff --git a/src/client/View/Payments/Table.elm b/src/client/View/Payments/Table.elm
index 06bec17..743a8a9 100644
--- a/src/client/View/Payments/Table.elm
+++ b/src/client/View/Payments/Table.elm
@@ -13,6 +13,7 @@ import Date exposing (Date)
import String exposing (append)
import Model exposing (Model)
+import Model.User exposing (getUserName)
import Model.Payment exposing (..)
import Model.View.PaymentView exposing (PaymentView)
import Model.Translations exposing (getMessage)
@@ -55,7 +56,13 @@ paymentLine model paymentView (id, payment) =
]
[ div [ class "cell category" ] [ text payment.name ]
, div [ class "cell cost" ] [ text ((toString payment.cost) ++ " " ++ (getMessage "MoneySymbol" model.translations)) ]
- , div [ class "cell user" ] [ text payment.userName ]
+ , div
+ [ class "cell user" ]
+ [ payment.userId
+ |> getUserName paymentView.users
+ |> Maybe.withDefault "−"
+ |> text
+ ]
, div
[ class "cell date" ]
[ span
@@ -65,11 +72,11 @@ paymentLine model paymentView (id, payment) =
[ class "longDate" ]
[ text (renderLongDate payment.creation model.translations) ]
]
- , if paymentView.userName == payment.userName
+ , if paymentView.me == payment.userId
then
div
[ class "cell remove"
- , onClick serverCommunications.address (SC.DeletePayment id payment.userName payment.cost paymentView.currentPage)
+ , onClick serverCommunications.address (SC.DeletePayment id payment.userId payment.cost paymentView.currentPage)
]
[ renderIcon "times" ]
else
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-23 02:00:22 +0000