From 6e93762eee8cfe4e77171237806c352092bdd7b6 Mon Sep 17 00:00:00 2001 From: nek0 Date: Tue, 28 Jul 2015 21:47:18 +0200 Subject: [PATCH] added possibility for cash transfer between users --- Application.hs | 1 + Handler/Transfer.hs | 90 +++++++++++++++++++++++++++++++++ config/routes | 2 + messages/de.msg | 5 ++ templates/select.hamlet | 3 ++ templates/transfer.hamlet | 14 +++++ templates/transferSelect.hamlet | 12 +++++ yammat.cabal | 1 + 8 files changed, 128 insertions(+) create mode 100644 Handler/Transfer.hs create mode 100644 templates/transfer.hamlet create mode 100644 templates/transferSelect.hamlet diff --git a/Application.hs b/Application.hs index 1a42a61..927c075 100644 --- a/Application.hs +++ b/Application.hs @@ -37,6 +37,7 @@ import Handler.Modify import Handler.CashCheck import Handler.Avatar import Handler.Barcode +import Handler.Transfer -- This line actually creates our YesodDispatch instance. It is the second half -- of the call to mkYesodData which occurs in Foundation.hs. Please see the diff --git a/Handler/Transfer.hs b/Handler/Transfer.hs new file mode 100644 index 0000000..6945590 --- /dev/null +++ b/Handler/Transfer.hs @@ -0,0 +1,90 @@ +module Handler.Transfer where + +import Import +import Handler.Common +import Data.Maybe +import Text.Shakespeare.Text (stext) + +getTransferSelectR :: UserId -> Handler Html +getTransferSelectR from = do + mUser <- runDB $ get from + case mUser of + Just user -> do + users <- runDB $ selectList [UserId !=. from] [Asc UserIdent] + defaultLayout $ do + $(widgetFile "transferSelect") + Nothing -> do + setMessageI MsgUserUnknown + redirect HomeR + +getTransferR :: UserId -> UserId -> Handler Html +getTransferR from to = do + mSender <- runDB $ get from + case mSender of + Just sender -> do + mRecpt <- runDB $ get to + case mRecpt of + Just recpt -> do + (transferWidget, enctype) <- generateFormPost transferForm + currency <- appCurrency <$> appSettings <$> getYesod + defaultLayout $ do + $(widgetFile "transfer") + Nothing -> do + setMessageI MsgUserUnknown + redirect $ TransferSelectR from + Nothing -> do + setMessageI MsgUserUnknown + redirect HomeR + +postTransferR :: UserId -> UserId -> Handler Html +postTransferR from to = do + mSender <- runDB $ get from + case mSender of + Just sender -> do + mRecpt <- runDB $ get to + case mRecpt of + Just recpt -> do + ((res, _), _) <- runFormPost transferForm + case res of + FormSuccess amount -> do + case amount < 0 of + False -> do + runDB $ update from [UserBalance -=. amount] + runDB $ update to [UserBalance +=. amount] + master <- getYesod + liftIO $ notify sender recpt amount master + setMessageI MsgTransferComplete + redirect HomeR + True -> do + setMessageI MsgNegativeTransfer + redirect $ TransferR from to + _ -> do + setMessageI MsgTransferError + redirect HomeR + Nothing -> do + setMessageI MsgUserUnknown + redirect $ TransferSelectR from + Nothing -> do + setMessageI MsgUserUnknown + redirect HomeR + +transferForm :: Form Int +transferForm = renderDivs + $ areq currencyField (fieldSettingsLabel MsgValue) (Just 0) + +notify :: User -> User -> Int -> App -> IO () +notify sender recpt amount master = do + case userEmail sender of + Just email -> + liftIO $ sendMail email "Guthabentransfer beim Matematen" + [stext| +Hallo #{userIdent sender} + +Du hast gerade #{formatIntCurrency amount}#{appCurrency $ appSettings master} an #{userIdent recpt} transferiert. + +Viele Grüßem + +Der Matemat + |] + Nothing -> + return () diff --git a/config/routes b/config/routes index 909dbfb..c238b7a 100644 --- a/config/routes +++ b/config/routes @@ -33,3 +33,5 @@ /barcode HomeBarcodeR GET /user/#UserId/barcode SelectBarcodeR GET !/user/cash/barcode SelectCashBarcodeR GET +/user/#UserId/transfer TransferSelectR GET +/user/#UserId/to/#UserId TransferR GET POST diff --git a/messages/de.msg b/messages/de.msg index eef11b7..e39e8fa 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -108,3 +108,8 @@ BarcodeUnknown: Dieser Barcode ist unbekannt BarcodeField: Barcodes BarcodeAdded: Barcode erfolgreich hinzugefügt BarcodeDuplicate: Dieser barcode wird schon verwendet +Transfer: Transferieren +TransferTo: Guthaben transferieren an +NegativeTransfer: Keine negativen Beträge transferieren +TransferComplete: Transfer abgeschlossen +TransferError: Fehler beim Transfer diff --git a/templates/select.hamlet b/templates/select.hamlet index 0b33a60..2711c6f 100644 --- a/templates/select.hamlet +++ b/templates/select.hamlet @@ -10,6 +10,9 @@ $doctype 5
  • _{MsgEditUser} +
  • + + _{MsgTransfer}

    _{MsgChoosePrompt $ userIdent user} diff --git a/templates/transfer.hamlet b/templates/transfer.hamlet new file mode 100644 index 0000000..2e45cb8 --- /dev/null +++ b/templates/transfer.hamlet @@ -0,0 +1,14 @@ +$doctype 5 + +

    + _{MsgTransferTo} #{userIdent recpt} + +

    + _{MsgCurrentCharge (userBalance sender) currency} + +

    + ^{transferWidget} +
    + + + diff --git a/templates/transferSelect.hamlet b/templates/transferSelect.hamlet new file mode 100644 index 0000000..c6836b2 --- /dev/null +++ b/templates/transferSelect.hamlet @@ -0,0 +1,12 @@ +$doctype 5 + +

    _{MsgTransferTo} + +$forall (Entity uId user) <- users +