yammat/Handler/Buy.hs

182 lines
5.9 KiB
Haskell
Raw Normal View History

2015-08-09 19:16:33 +00:00
-- yammat - Yet Another MateMAT
-- Copyright (C) 2015 Amedeo Molnár
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published
-- by the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
2015-04-04 04:46:33 +00:00
module Handler.Buy where
import Import
import Handler.Common
2015-04-07 20:03:21 +00:00
import Text.Shakespeare.Text
2015-04-04 04:46:33 +00:00
2018-10-02 18:51:56 +00:00
import qualified Data.Text as T (pack)
2015-04-04 04:46:33 +00:00
getBuyR :: UserId -> BeverageId -> Handler Html
getBuyR uId bId = do
2018-10-02 18:51:56 +00:00
mpin <- lookupSession "pinentry"
case mpin of
Just ppin ->
if ppin == T.pack (show uId)
then do
(user, bev) <- checkData uId bId
master <- getYesod
(buyWidget, enctype) <- generateFormPost
$ renderBootstrap3 BootstrapBasicForm
$ buyForm
defaultLayout $ do
setTitleI (MsgPurchaseOf (beverageIdent bev))
$(widgetFile "buy")
else do
deleteSession "pinentry"
setMessageI MsgWrongPin
redirect HomeR
Nothing -> do
setMessageI MsgWrongPin
redirect HomeR
2015-04-04 04:46:33 +00:00
postBuyR :: UserId -> BeverageId -> Handler Html
postBuyR uId bId = do
2018-10-02 18:51:56 +00:00
mpin <- lookupSession "pinentry"
case mpin of
Just ppin ->
if ppin == T.pack (show uId)
then do
(user, bev) <- checkData uId bId
((res, _), _) <- runFormPost
$ renderBootstrap3 BootstrapBasicForm
$ buyForm
case res of
FormSuccess quant -> do
if quant > beverageAmount bev
then do
setMessageI MsgNotEnoughItems
redirect $ BuyR uId bId
else do
let price = quant * (beveragePrice bev)
let sw = price > (userBalance user)
today <- liftIO $ return . utctDay =<< getCurrentTime
runDB $ do
update uId [UserTimestamp =. today]
update uId [UserBalance -=. price]
update bId [BeverageAmount -=. quant]
update bId [BeverageTotalBought +=. 1]
checkAlert bId (beverageAmount bev)
master <- getYesod
liftIO $ notifyUser user bev quant price master
case sw of
False -> do
deleteSession "pinentry"
setMessageI MsgPurchaseSuccess
redirect HomeR
True -> do
deleteSession "pinentry"
let level = case userBalance user - price of
balance
| balance <= -5000 -> 3
| balance <= -1000 -> 2
| otherwise -> 1
redirect $ DemandR level
_ -> do
deleteSession "pinentry"
setMessageI MsgErrorOccured
redirect HomeR
else do
deleteSession "pinentry"
setMessageI MsgWrongPin
redirect HomeR
Nothing -> do
setMessageI MsgWrongPin
2015-09-14 22:49:13 +00:00
redirect HomeR
2015-04-04 04:46:33 +00:00
notifyUser :: User -> Beverage -> Int -> Int -> App -> IO ()
notifyUser user bev quant price master = do
case userEmail user of
Just email -> do
2016-03-30 19:53:33 +00:00
addendum <- if (userBalance user - price) < 0
then
return $
"\n\nDein Guthaben Beträgt im Moment " ++
2016-03-23 05:31:44 +00:00
formatIntCurrency (userBalance user - price) ++
appCurrency (appSettings master) ++
".\n" ++
"LADE DEIN GUTHABEN AUF!\n" ++
"VERDAMMT NOCHMAL!!!"
else
return ""
liftIO $ sendMail email "Einkauf beim Matematen"
[lt|
2015-04-07 20:03:21 +00:00
Hallo #{userIdent user},
Du hast gerade beim Matematen #{quant} x #{beverageIdent bev} für #{formatIntCurrency price}#{appCurrency $ appSettings master} eingekauft.#{addendum}
2015-04-07 20:03:21 +00:00
Viele Grüße,
2015-04-07 20:03:21 +00:00
2016-02-02 23:25:06 +00:00
Dein Matemat
|]
Nothing ->
2015-04-07 20:03:21 +00:00
return ()
2015-04-04 04:46:33 +00:00
getBuyCashR :: BeverageId -> Handler Html
getBuyCashR bId = do
mBev <- runDB $ get bId
case mBev of
Just bev -> do
2015-04-04 06:18:15 +00:00
master <- getYesod
2015-10-22 21:57:27 +00:00
(buyCashWidget, enctype) <- generateFormPost
$ renderBootstrap3 BootstrapBasicForm
$ buyForm
2018-09-04 16:06:12 +00:00
defaultLayout $ do
setTitleI (MsgPurchaseOf (beverageIdent bev))
2015-04-04 04:46:33 +00:00
$(widgetFile "buyCash")
Nothing -> do
2015-04-09 22:40:58 +00:00
setMessageI MsgItemUnknown
2015-09-14 22:49:13 +00:00
redirect HomeR
2015-04-04 04:46:33 +00:00
postBuyCashR :: BeverageId -> Handler Html
2016-05-23 18:35:14 +00:00
postBuyCashR bId =
isBeverage bId HomeR >>= (\bev -> do
((res, _), _) <- runFormPost
$ renderBootstrap3 BootstrapBasicForm
$ buyForm
case res of
FormSuccess quant -> do
if quant > beverageAmount bev
then do
setMessageI MsgNotEnoughItems
redirect $ BuyCashR bId
else do
master <- getYesod
let price = quant * (beveragePrice bev + appCashCharge (appSettings master))
runDB $ update bId [BeverageAmount -=. quant]
updateCashier price "Barzahlung"
checkAlert bId (beverageAmount bev)
2016-05-23 18:35:14 +00:00
let currency = appCurrency $ appSettings master
setMessageI $ MsgPurchaseSuccessCash price currency
redirect HomeR
_ -> do
setMessageI MsgItemDisappeared
redirect HomeR
)
2015-04-04 04:46:33 +00:00
2016-05-23 18:35:14 +00:00
checkData :: UserId -> BeverageId -> Handler (User, Beverage)
checkData uId bId =
isUser uId HomeR >>= (\user -> do
isBeverage bId HomeR >>= (\bev ->
return (user, bev)
)
)
2015-04-04 04:46:33 +00:00
2015-10-22 21:57:27 +00:00
buyForm :: AForm Handler Int
buyForm = areq amountField (bfs MsgAmount) (Just 1)
<* bootstrapSubmit (msgToBSSubmit MsgPurchase)