Server payament delete

6 files changed, 52 insertions, 5 deletions

diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs
index 141aed0..cbd342a 100644
--- a/src/server/Controller/Payment.hs
+++ b/src/server/Controller/Payment.hs
@@ -1,10 +1,13 @@
 module Controller.Payment
   ( getPaymentsAction
   , createPaymentAction
+  , deletePaymentAction
   ) where
 
 import Web.Scotty
 
+import Network.HTTP.Types.Status (ok200, badRequest400)
+
 import Database.Persist
 
 import Control.Monad.IO.Class (liftIO)
@@ -16,6 +19,8 @@ import qualified Secure
 import Model.Database
 import Model.Payment
 import Model.Json.Message
+import Model.Message
+import Model.Message.Key (Key(PaymentNotDeleted))
 
 getPaymentsAction :: ActionM ()
 getPaymentsAction =
@@ -30,3 +35,15 @@ createPaymentAction name cost =
     paymentKey <- liftIO . runDb $ createPayment (entityKey user) name cost
     json . Message . paymentKeyToText $ paymentKey
   )
+
+deletePaymentAction :: Text -> ActionM ()
+deletePaymentAction paymentId =
+  Secure.loggedAction (\user -> do
+    deleted <- liftIO . runDb $ deleteOwnPayment user (textToKey paymentId)
+    if deleted
+      then
+        status ok200
+      else do
+        status badRequest400
+        json . Message . getMessage $ PaymentNotDeleted
+  )
diff --git a/src/server/Main.hs b/src/server/Main.hs
index 0828e0d..1363f33 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -50,6 +50,10 @@ main = do
           cost <- param "cost" :: ActionM Int
           createPaymentAction name cost
 
+        post "/payment/delete" $ do
+          paymentId <- param "id" :: ActionM Text
+          deletePaymentAction paymentId
+
         post "/signOut" $
           signOutAction
 
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