added possibility for cash transfer between users

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

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 ()

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

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

templates/select.hamlet

@@ -10,6 +10,9 @@ $doctype 5
     <li>
       <a href=@{ModifyUserR uId}>
         _{MsgEditUser}
+    <li>
+      <a href=@{TransferSelectR uId}>
+        _{MsgTransfer}
 
 <h3>_{MsgChoosePrompt $ userIdent user}
 

templates/transfer.hamlet

@@ -0,0 +1,14 @@
+$doctype 5
+
+<h3>
+  _{MsgTransferTo} #{userIdent recpt}
+
+<p>
+  _{MsgCurrentCharge (userBalance sender) currency}
+
+<form method=post enctype=#{enctype}>
+  ^{transferWidget}
+  <div>
+    <input type=submit value="_{MsgTransfer}">
+    <input onclick="crmnt( document.getElementById('hident2'), 5 )" value="_{MsgPlus5}" type="button">
+    <input onclick="crmnt( document.getElementById('hident2'), -5 )" value="_{MsgMinus5}" type="button">

templates/transferSelect.hamlet

@@ -0,0 +1,12 @@
+$doctype 5
+
+<h3>_{MsgTransferTo}
+
+$forall (Entity uId user) <- users
+  <article .article>
+    $if userAvatar user /= Nothing
+      <a href=@{TransferR from uId} style="background-image: url(@{GetAvatarR $ fromJust $ userAvatar user})" .avatar>
+        <p>#{userIdent user}
+    $else
+      <a href=@{TransferR from uId}>
+        <p>#{userIdent user}

yammat.cabal

@@ -32,6 +32,7 @@ library
                      Handler.CashCheck
                      Handler.Avatar
                      Handler.Barcode
+                     Handler.Transfer
 
     if flag(dev) || flag(library-only)
         cpp-options:   -DDEVELOPMENT