From fd86f021e88a00348ac0e03f03d81cb15bf3042b Mon Sep 17 00:00:00 2001 From: Joris Date: Thu, 27 Aug 2015 20:36:18 +0200 Subject: Server payament delete --- src/client/ServerCommunication.elm | 35 ++++++++++++++++---------------- src/client/View/Payments/Table.elm | 16 ++++++++++----- src/server/Controller/Payment.hs | 17 ++++++++++++++++ src/server/Main.hs | 4 ++++ src/server/Model/Database.hs | 6 ++++-- src/server/Model/Message/Key.hs | 1 + src/server/Model/Message/Translations.hs | 5 +++++ src/server/Model/Payment.hs | 24 +++++++++++++++++++--- 8 files changed, 80 insertions(+), 28 deletions(-) (limited to 'src') diff --git a/src/client/ServerCommunication.elm b/src/client/ServerCommunication.elm index b4b547d..010b3df 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.Payment exposing (PaymentId) import Update as U import Update.SignIn exposing (..) @@ -20,6 +21,7 @@ type Communication = NoCommunication | SignIn String | AddPayment String Int + | DeletePayment PaymentId | SignOut serverCommunications : Signal.Mailbox Communication @@ -40,26 +42,21 @@ getRequest communication = NoCommunication -> Nothing SignIn login -> - Just - { verb = "post" - , headers = [] - , url = "/signIn?login=" ++ login - , body = Http.empty - } + Just (simplePost ("/signIn?login=" ++ login)) AddPayment name cost -> - Just - { verb = "post" - , headers = [] - , url = "/payment/add?name=" ++ name ++ "&cost=" ++ (toString cost) - , body = Http.empty - } + Just (simplePost ("/payment/add?name=" ++ name ++ "&cost=" ++ (toString cost))) + DeletePayment paymentId -> + Just (simplePost ("payment/delete?id=" ++ paymentId)) SignOut -> - Just - { verb = "post" - , headers = [] - , url = "/signOut" - , body = Http.empty - } + Just (simplePost "/signout") + +simplePost : String -> Http.Request +simplePost url = + { verb = "post" + , headers = [] + , url = url + , body = Http.empty + } communicationToAction : Communication -> Http.Response -> U.Action communicationToAction communication response = @@ -74,6 +71,8 @@ communicationToAction communication response = decodeResponse response (\id -> U.UpdatePayment (UP.AddPayment id name cost)) + DeletePayment id -> + U.UpdatePayment (UP.Remove id) SignOut -> U.GoSignInView else diff --git a/src/client/View/Payments/Table.elm b/src/client/View/Payments/Table.elm index 9033db8..50dd151 100644 --- a/src/client/View/Payments/Table.elm +++ b/src/client/View/Payments/Table.elm @@ -16,6 +16,8 @@ import Model exposing (Model) import Model.Payment exposing (..) import Model.View.PaymentView exposing (PaymentView) +import ServerCommunication as SC exposing (serverCommunications) + import Update exposing (..) import Update.Payment exposing (..) @@ -54,9 +56,13 @@ paymentLine model paymentView (id, payment) = , div [ class "cell" ] [ text ((toString payment.cost) ++ " €") ] , div [ class "cell" ] [ text payment.userName ] , div [ class "cell" ] [ text (renderDate payment.creation model.translations) ] - , div - [ class "cell remove" - , onClick actions.address (UpdatePayment (Remove id)) - ] - [ renderIcon "times" ] + , if paymentView.userName == payment.userName + then + div + [ class "cell remove" + , onClick serverCommunications.address (SC.DeletePayment id) + ] + [ renderIcon "times" ] + else + div [ class "cell" ] [] ] 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 -- cgit v1.2.3