aboutsummaryrefslogtreecommitdiff
path: root/src/server/Model
diff options
context:
space:
mode:
Diffstat (limited to 'src/server/Model')
-rw-r--r--src/server/Model/Database.hs6
-rw-r--r--src/server/Model/Message/Key.hs1
-rw-r--r--src/server/Model/Message/Translations.hs5
-rw-r--r--src/server/Model/Payment.hs24
4 files changed, 31 insertions, 5 deletions
diff --git a/src/server/Model/Database.hs b/src/server/Model/Database.hs
index 7f1777a..8715ca1 100644
--- a/src/server/Model/Database.hs
+++ b/src/server/Model/Database.hs
@@ -27,12 +27,14 @@ User
email Text
name Text
EmailKey email
+ UniqName name
deriving Show
Payment
userId UserId
creation UTCTime
name Text
cost Int
+ deletedAt UTCTime Maybe
deriving Show
SignIn
token Text
@@ -51,5 +53,5 @@ runDb = runNoLoggingT . runResourceT . withSqliteConn "database" . runSqlConn
runMigrations :: IO ()
runMigrations = runDb $ runMigration migrateAll
-textToKey :: (ToBackendKey SqlBackend a) => String -> Key a
-textToKey text = toSqlKey (read text :: Int64)
+textToKey :: (ToBackendKey SqlBackend a) => Text -> Key a
+textToKey text = toSqlKey (read (unpack text) :: Int64)
diff --git a/src/server/Model/Message/Key.hs b/src/server/Model/Message/Key.hs
index 9b5c69e..b5ea45b 100644
--- a/src/server/Model/Message/Key.hs
+++ b/src/server/Model/Message/Key.hs
@@ -49,5 +49,6 @@ data Key =
-- Payments
| Add
+ | PaymentNotDeleted
deriving (Enum, Bounded, Show)
diff --git a/src/server/Model/Message/Translations.hs b/src/server/Model/Message/Translations.hs
index 62381a7..c0f9d3c 100644
--- a/src/server/Model/Message/Translations.hs
+++ b/src/server/Model/Message/Translations.hs
@@ -184,3 +184,8 @@ m l Add =
case l of
English -> "Add"
French -> "Ajouter"
+
+m l PaymentNotDeleted =
+ case l of
+ English -> "The payment could not have been deleted."
+ French -> "Le paiement n'a pas pu ĂȘtre supprimĂ©."
diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs
index 2e191b9..51f09b9 100644
--- a/src/server/Model/Payment.hs
+++ b/src/server/Model/Payment.hs
@@ -2,6 +2,7 @@ module Model.Payment
( getPayments
, createPayment
, paymentKeyToText
+ , deleteOwnPayment
) where
import Data.Text (Text)
@@ -11,6 +12,7 @@ import Data.Time.Clock (getCurrentTime)
import Control.Monad.IO.Class (liftIO)
import Database.Persist
+import qualified Database.Persist as P
import Database.Esqueleto
import qualified Database.Esqueleto as E
@@ -21,8 +23,9 @@ getPayments :: Persist [P.Payment]
getPayments = do
xs <- select $
from $ \(payment `InnerJoin` user) -> do
- on (payment ^. PaymentUserId E.==. user ^. UserId)
- return (payment, user)
+ on (payment ^. PaymentUserId E.==. user ^. UserId)
+ where_ (isNothing (payment ^. PaymentDeletedAt))
+ return (payment, user)
return (map getJsonPayment xs)
getJsonPayment :: (Entity Payment, Entity User) -> P.Payment
@@ -43,4 +46,19 @@ paymentKeyToText = T.pack . show . unSqlBackendKey . unPaymentKey
createPayment :: UserId -> Text -> Int -> Persist PaymentId
createPayment userId name cost = do
now <- liftIO getCurrentTime
- insert $ Payment userId now name cost
+ insert $ Payment userId now name cost Nothing
+
+deleteOwnPayment :: Entity User -> PaymentId -> Persist Bool
+deleteOwnPayment user paymentId = do
+ mbPayment <- get paymentId
+ case mbPayment of
+ Just payment ->
+ if paymentUserId payment == entityKey user
+ then do
+ now <- liftIO getCurrentTime
+ P.update paymentId [PaymentDeletedAt P.=. Just now]
+ return True
+ else
+ return False
+ Nothing ->
+ return False