yammat/Handler/Buy.hs

143 lines
4.5 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
import qualified Data.Text as T
import Text.Blaze.Internal
2015-04-07 20:03:21 +00:00
import Text.Shakespeare.Text
2015-04-04 04:46:33 +00:00
getBuyR :: UserId -> BeverageId -> Handler Html
getBuyR uId bId = do
mTup <- checkData uId bId
case mTup of
Just (user, bev) -> do
2015-04-04 06:18:15 +00:00
master <- getYesod
2015-04-04 04:46:33 +00:00
(buyWidget, enctype) <- generateFormPost buyForm
defaultLayout $ do
$(widgetFile "buy")
Nothing -> do
2015-04-09 22:40:58 +00:00
setMessageI MsgUserOrArticleUnknown
2015-04-04 04:46:33 +00:00
redirect $ HomeR
postBuyR :: UserId -> BeverageId -> Handler Html
postBuyR uId bId = do
mTup <- checkData uId bId
case mTup of
Just (user, bev) -> do
((res, _), _) <- runFormPost buyForm
case res of
FormSuccess quant -> do
case quant > beverageAmount bev of
2015-04-04 04:46:33 +00:00
False -> do
price <- return $ quant * (beveragePrice bev)
sw <- return $ price > (userBalance user)
runDB $ update uId [UserBalance -=. price]
runDB $ update bId [BeverageAmount -=. quant]
checkAlert bId
2015-04-07 20:03:21 +00:00
master <- getYesod
liftIO $ notifyUser user bev price master
case sw of
False -> do
2015-04-09 22:40:58 +00:00
setMessageI MsgPurchaseSuccess
redirect $ HomeR
True -> do
2015-04-09 22:40:58 +00:00
setMessageI MsgPurchaseDebtful
redirect $ HomeR
2015-04-04 04:46:33 +00:00
True -> do
2015-04-09 22:40:58 +00:00
setMessageI MsgNotEnoughItems
redirect $ BuyR uId bId
2015-04-04 04:46:33 +00:00
_ -> do
2015-04-09 22:40:58 +00:00
setMessageI MsgErrorOccured
2015-04-04 04:46:33 +00:00
redirect $ HomeR
Nothing -> do
2015-04-09 22:40:58 +00:00
setMessageI MsgUserUnknown
2015-04-04 04:46:33 +00:00
redirect $ HomeR
2015-04-07 20:03:21 +00:00
notifyUser :: User -> Beverage -> Int -> App -> IO ()
notifyUser user bev price master = do
case userEmail user of
Just email ->
liftIO $ sendMail email "Einkauf beim Matematen"
[stext|
2015-04-07 20:03:21 +00:00
Hallo #{userIdent user},
Du hast gerade beim Matematen für #{formatIntCurrency price}#{appCurrency $ appSettings master} #{beverageIdent bev} eingekauft.
Viele Grüsse,
Der 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-04-04 04:46:33 +00:00
(buyCashWidget, enctype) <- generateFormPost buyForm
defaultLayout $ do
$(widgetFile "buyCash")
Nothing -> do
2015-04-09 22:40:58 +00:00
setMessageI MsgItemUnknown
2015-04-04 04:46:33 +00:00
redirect $ HomeR
postBuyCashR :: BeverageId -> Handler Html
postBuyCashR bId = do
mBev <- runDB $ get bId
case mBev of
Just bev -> do
((res, _), _) <- runFormPost buyForm
case res of
FormSuccess quant -> do
case quant > beverageAmount bev of
False -> do
master <- getYesod
price <- return $ quant * (beveragePrice bev + (appCashCharge $ appSettings master))
runDB $ update bId [BeverageAmount -=. quant]
updateCashier price "Barzahlung"
checkAlert bId
2015-04-09 22:40:58 +00:00
let currency = appCurrency $ appSettings master
setMessageI $ MsgPurchaseSuccessCash price currency
redirect HomeR
True -> do
2015-04-09 22:40:58 +00:00
setMessageI MsgNotEnoughItems
redirect $ BuyCashR bId
2015-04-04 04:46:33 +00:00
_ -> do
2015-04-09 22:40:58 +00:00
setMessageI MsgItemDisappeared
2015-04-04 04:46:33 +00:00
redirect $ HomeR
Nothing -> do
2015-04-09 22:40:58 +00:00
setMessageI MsgItemUnknown
2015-04-04 04:46:33 +00:00
redirect $ HomeR
checkData :: UserId -> BeverageId -> Handler (Maybe (User, Beverage))
checkData uId bId = do
mUser <- runDB $ get uId
mBev <- runDB $ get bId
case mUser of
Just user -> do
case mBev of
Just bev -> return $ Just (user, bev)
Nothing -> return Nothing
Nothing -> return Nothing
buyForm :: Form Int
buyForm = renderDivs
2015-04-09 22:40:58 +00:00
$ areq amountField (fieldSettingsLabel MsgAmount) (Just 1)