Server payament delete

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