nek0/yammat
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

deduplication

Browse source
This commit is contained in:
nek0 2016-05-23 20:35:14 +02:00
parent 994f2a751f
commit bc3e52cb90
7 changed files with 284 additions and 337 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

161
Handler/Buy.hs
View file

@ -21,60 +21,50 @@ import Text.Shakespeare.Text
getBuyR :: UserId -> BeverageId -> Handler Html getBuyR :: UserId -> BeverageId -> Handler Html
getBuyR uId bId = do getBuyR uId bId = do
mTup <- checkData uId bId (_, bev) <- checkData uId bId
case mTup of master <- getYesod
Just (_, bev) -> do (buyWidget, enctype) <- generateFormPost
master <- getYesod $ renderBootstrap3 BootstrapBasicForm
(buyWidget, enctype) <- generateFormPost $ buyForm
$ renderBootstrap3 BootstrapBasicForm defaultLayout $
$ buyForm $(widgetFile "buy")
defaultLayout $
$(widgetFile "buy")
Nothing -> do
setMessageI MsgUserOrArticleUnknown
redirect HomeR
postBuyR :: UserId -> BeverageId -> Handler Html postBuyR :: UserId -> BeverageId -> Handler Html
postBuyR uId bId = do postBuyR uId bId = do
mTup <- checkData uId bId (user, bev) <- checkData uId bId
case mTup of ((res, _), _) <- runFormPost
Just (user, bev) -> do $ renderBootstrap3 BootstrapBasicForm
((res, _), _) <- runFormPost $ buyForm
$ renderBootstrap3 BootstrapBasicForm case res of
$ buyForm FormSuccess quant -> do
case res of if quant > beverageAmount bev
FormSuccess quant -> do then do
if quant > beverageAmount bev setMessageI MsgNotEnoughItems
then do redirect $ BuyR uId bId
setMessageI MsgNotEnoughItems else do
redirect $ BuyR uId bId let price = quant * (beveragePrice bev)
else do let sw = price > (userBalance user)
let price = quant * (beveragePrice bev) today <- liftIO $ return . utctDay =<< getCurrentTime
let sw = price > (userBalance user) runDB $ do
today <- liftIO $ return . utctDay =<< getCurrentTime update uId [UserTimestamp =. today]
runDB $ do update uId [UserBalance -=. price]
update uId [UserTimestamp =. today] update bId [BeverageAmount -=. quant]
update uId [UserBalance -=. price] checkAlert bId
update bId [BeverageAmount -=. quant] master <- getYesod
checkAlert bId liftIO $ notifyUser user bev quant price master
master <- getYesod case sw of
liftIO $ notifyUser user bev quant price master False -> do
case sw of setMessageI MsgPurchaseSuccess
False -> do redirect HomeR
setMessageI MsgPurchaseSuccess True -> do
redirect HomeR let level = case userBalance user - price of
True -> do balance
let level = case userBalance user - price of | balance <= -5000 -> 3
balance | balance <= -1000 -> 2
| balance <= -5000 -> 3 | otherwise -> 1
| balance <= -1000 -> 2 redirect $ DemandR level
| otherwise -> 1 _ -> do
redirect $ DemandR level setMessageI MsgErrorOccured
_ -> do
setMessageI MsgErrorOccured
redirect HomeR
Nothing -> do
setMessageI MsgUserUnknown
redirect HomeR redirect HomeR
notifyUser :: User -> Beverage -> Int -> Int -> App -> IO () notifyUser :: User -> Beverage -> Int -> Int -> App -> IO ()
@ -121,45 +111,38 @@ getBuyCashR bId = do
redirect HomeR redirect HomeR
postBuyCashR :: BeverageId -> Handler Html postBuyCashR :: BeverageId -> Handler Html
postBuyCashR bId = do postBuyCashR bId =
mBev <- runDB $ get bId isBeverage bId HomeR >>= (\bev -> do
case mBev of ((res, _), _) <- runFormPost
Just bev -> do $ renderBootstrap3 BootstrapBasicForm
((res, _), _) <- runFormPost $ buyForm
$ renderBootstrap3 BootstrapBasicForm case res of
$ buyForm FormSuccess quant -> do
case res of if quant > beverageAmount bev
FormSuccess quant -> do then do
if quant > beverageAmount bev setMessageI MsgNotEnoughItems
then do redirect $ BuyCashR bId
setMessageI MsgNotEnoughItems else do
redirect $ BuyCashR bId master <- getYesod
else do let price = quant * (beveragePrice bev + appCashCharge (appSettings master))
master <- getYesod runDB $ update bId [BeverageAmount -=. quant]
let price = quant * (beveragePrice bev + appCashCharge (appSettings master)) updateCashier price "Barzahlung"
runDB $ update bId [BeverageAmount -=. quant] checkAlert bId
updateCashier price "Barzahlung" let currency = appCurrency $ appSettings master
checkAlert bId setMessageI $ MsgPurchaseSuccessCash price currency
let currency = appCurrency $ appSettings master redirect HomeR
setMessageI $ MsgPurchaseSuccessCash price currency _ -> do
redirect HomeR setMessageI MsgItemDisappeared
_ -> do redirect HomeR
setMessageI MsgItemDisappeared )
redirect HomeR
Nothing -> do
setMessageI MsgItemUnknown
redirect HomeR
checkData :: UserId -> BeverageId -> Handler (Maybe (User, Beverage)) checkData :: UserId -> BeverageId -> Handler (User, Beverage)
checkData uId bId = do checkData uId bId =
mUser <- runDB $ get uId isUser uId HomeR >>= (\user -> do
mBev <- runDB $ get bId isBeverage bId HomeR >>= (\bev ->
case mUser of return (user, bev)
Just user -> do )
case mBev of )
Just bev -> return $ Just (user, bev)
Nothing -> return Nothing
Nothing -> return Nothing
buyForm :: AForm Handler Int buyForm :: AForm Handler Int
buyForm = areq amountField (bfs MsgAmount) (Just 1) buyForm = areq amountField (bfs MsgAmount) (Just 1)

24
Handler/Common.hs
View file

@ -223,3 +223,27 @@ sendMail to subject body =
formatIntVolume :: Int -> Text formatIntVolume :: Int -> Text
formatIntVolume x = formatFloat (fromIntegral x / 1000) formatIntVolume x = formatFloat (fromIntegral x / 1000)
--------------------------------------------------------------------------------
-- common case patterns
--------------------------------------------------------------------------------
isUser :: UserId -> Route App -> Handler User
isUser uId route = do
mUser <- runDB $ get uId
case mUser of
Nothing -> do
setMessageI MsgUserUnknown
redirect route
Just user ->
return user
isBeverage :: BeverageId -> Route App -> Handler Beverage
isBeverage bId route = do
mBev <- runDB $ get bId
case mBev of
Nothing -> do
setMessageI MsgItemUnknown
redirect route
Just bev ->
return bev

108
Handler/Modify.hs
View file

@ -19,58 +19,50 @@ import Import
import Handler.Common import Handler.Common
getModifyR :: BeverageId -> Handler Html getModifyR :: BeverageId -> Handler Html
getModifyR bId = do getModifyR bId =
mBev <- runDB $ get bId isBeverage bId SummaryR >>= (\bev -> do
case mBev of p <- lookupGetParam "barcode"
Just bev -> do _ <- handleGetParam p (Right bId)
p <- lookupGetParam "barcode" rawbs <- runDB $ selectList [BarcodeBev ==. Just bId] []
_ <- handleGetParam p (Right bId) let bs = map (barcodeCode . entityVal) rawbs
rawbs <- runDB $ selectList [BarcodeBev ==. Just bId] [] (modifyWidget, enctype) <- generateFormPost
let bs = map (barcodeCode . entityVal) rawbs $ renderBootstrap3 BootstrapBasicForm
(modifyWidget, enctype) <- generateFormPost $ modifyForm bev bs
$ renderBootstrap3 BootstrapBasicForm defaultLayout $
$ modifyForm bev bs $(widgetFile "modify")
defaultLayout $ )
$(widgetFile "modify")
Nothing -> do
setMessageI MsgItemUnknown
redirect SummaryR
postModifyR :: BeverageId -> Handler Html postModifyR :: BeverageId -> Handler Html
postModifyR bId = do postModifyR bId =
mBev <- runDB $ get bId isBeverage bId SummaryR >>= (\bev -> do
case mBev of rawbs <- runDB $ selectList [BarcodeBev ==. Just bId] []
Just bev -> do let bs = map (barcodeCode . entityVal) rawbs
rawbs <- runDB $ selectList [BarcodeBev ==. Just bId] [] ((res, _), _) <- runFormPost
let bs = map (barcodeCode . entityVal) rawbs $ renderBootstrap3 BootstrapBasicForm
((res, _), _) <- runFormPost $ modifyForm bev bs
$ renderBootstrap3 BootstrapBasicForm case res of
$ modifyForm bev bs FormSuccess nBev -> do
case res of runDB $ update bId
FormSuccess nBev -> do [ BeverageIdent =. modBevIdent nBev
runDB $ update bId , BeveragePrice =. modBevPrice nBev
[ BeverageIdent =. modBevIdent nBev , BeverageAmount =. modBevAmount nBev
, BeveragePrice =. modBevPrice nBev , BeverageAlertAmount =. modBevAlertAmount nBev
, BeverageAmount =. modBevAmount nBev , BeverageCorrectedAmount +=. (modBevAmount nBev - beverageAmount bev)
, BeverageAlertAmount =. modBevAlertAmount nBev , BeverageMl =. modBevMl nBev
, BeverageCorrectedAmount +=. (modBevAmount nBev - beverageAmount bev) , BeverageAvatar =. modBevAvatar nBev
, BeverageMl =. modBevMl nBev , BeverageSupplier =. modBevSupp nBev
, BeverageAvatar =. modBevAvatar nBev , BeverageMaxAmount =. modBevMaxAmount nBev
, BeverageSupplier =. modBevSupp nBev , BeveragePerCrate =. modBevPC nBev
, BeverageMaxAmount =. modBevMaxAmount nBev , BeverageArtNr =. modBevArtNr nBev
, BeveragePerCrate =. modBevPC nBev , BeveragePricePerCrate =. modBevPricePC nBev
, BeverageArtNr =. modBevArtNr nBev ]
, BeveragePricePerCrate =. modBevPricePC nBev handleBarcodes (Right bId) (fromMaybe [] $ modBevBarcodes nBev)
] setMessageI MsgEditSuccess
handleBarcodes (Right bId) (fromMaybe [] $ modBevBarcodes nBev) redirect SummaryR
setMessageI MsgEditSuccess _ -> do
redirect SummaryR setMessageI MsgEditFail
_ -> do redirect SummaryR
setMessageI MsgEditFail )
redirect SummaryR
Nothing -> do
setMessageI MsgItemUnknown
redirect SummaryR
data ModBev = ModBev data ModBev = ModBev
{ modBevIdent :: Text { modBevIdent :: Text
@ -107,13 +99,9 @@ modifyForm bev bs = ModBev
sups = optionsPersistKey [] [Asc SupplierIdent] supplierIdent sups = optionsPersistKey [] [Asc SupplierIdent] supplierIdent
getDeleteBeverageR :: BeverageId -> Handler Html getDeleteBeverageR :: BeverageId -> Handler Html
getDeleteBeverageR bId = do getDeleteBeverageR bId =
mBev <- runDB $ get bId isBeverage bId HomeR >>= (\_ -> do
case mBev of runDB $ delete bId
Just _ -> do setMessageI MsgItemDeleted
runDB $ delete bId redirect HomeR
setMessageI MsgItemDeleted )
redirect HomeR
Nothing -> do
setMessageI MsgItemUnknown
redirect HomeR

88
Handler/NewUser.hs
View file

@ -70,56 +70,48 @@ data UserConf = UserConf
} }
getModifyUserR :: UserId -> Handler Html getModifyUserR :: UserId -> Handler Html
getModifyUserR uId = do getModifyUserR uId =
mUser <- runDB $ I.get uId isUser uId HomeR >>= (\user -> do
case mUser of p <- lookupGetParam "barcode"
Just user -> do _ <- handleGetParam p (Left uId)
p <- lookupGetParam "barcode" rawbs <- runDB $ selectList [BarcodeUser ==. Just uId] []
_ <- handleGetParam p (Left uId) let bs = map (barcodeCode . entityVal) rawbs
rawbs <- runDB $ selectList [BarcodeUser ==. Just uId] [] (modifyUserWidget, enctype) <- generateFormPost
let bs = map (barcodeCode . entityVal) rawbs $ renderBootstrap3 BootstrapBasicForm
(modifyUserWidget, enctype) <- generateFormPost $ modifyUserForm user bs
$ renderBootstrap3 BootstrapBasicForm defaultLayout $
$ modifyUserForm user bs $(widgetFile "modifyUser")
defaultLayout $ )
$(widgetFile "modifyUser")
Nothing -> do
setMessageI MsgUserUnknown
redirect HomeR
postModifyUserR :: UserId -> Handler Html postModifyUserR :: UserId -> Handler Html
postModifyUserR uId = do postModifyUserR uId =
mUser <- runDB $ I.get uId isUser uId HomeR >>= (\user -> do
case mUser of rawbs <- runDB $ selectList [BarcodeUser ==. Just uId] []
Just user -> do let bs = map (barcodeCode . entityVal) rawbs
rawbs <- runDB $ selectList [BarcodeUser ==. Just uId] [] ((res, _), _) <- runFormPost
let bs = map (barcodeCode . entityVal) rawbs $ renderBootstrap3 BootstrapBasicForm
((res, _), _) <- runFormPost $ modifyUserForm user bs
$ renderBootstrap3 BootstrapBasicForm case res of
$ modifyUserForm user bs FormSuccess uc -> do
case res of namesakes <- runDB $ selectList [UserIdent ==. userConfIdent uc, UserId !=. uId] []
FormSuccess uc -> do if null namesakes
namesakes <- runDB $ selectList [UserIdent ==. userConfIdent uc, UserId !=. uId] [] then do
if null namesakes runDB $ update uId
then do [ UserIdent =. userConfIdent uc
runDB $ update uId , UserEmail =. userConfEmail uc
[ UserIdent =. userConfIdent uc , UserAvatar =. userConfAvatar uc
, UserEmail =. userConfEmail uc ]
, UserAvatar =. userConfAvatar uc liftIO $ notify user (userConfEmail uc)
] handleBarcodes (Left uId) (fromMaybe [] $ userConfBarcode uc)
liftIO $ notify user (userConfEmail uc) setMessageI MsgUserEdited
handleBarcodes (Left uId) (fromMaybe [] $ userConfBarcode uc) redirect $ SelectR uId
setMessageI MsgUserEdited else do
redirect $ SelectR uId setMessageI MsgUserIdentNotUnique
else do redirect $ ModifyUserR uId
setMessageI MsgUserIdentNotUnique _ -> do
redirect $ ModifyUserR uId setMessageI MsgUserNotEdited
_ -> do redirect $ SelectR uId
setMessageI MsgUserNotEdited )
redirect $ SelectR uId
Nothing -> do
setMessageI MsgUserUnknown
redirect HomeR
modifyUserForm :: User -> [Text] -> AForm Handler UserConf modifyUserForm :: User -> [Text] -> AForm Handler UserConf
modifyUserForm user bs = UserConf modifyUserForm user bs = UserConf

62
Handler/Restock.hs
View file

@ -26,43 +26,35 @@ getRestockR = do
$(widgetFile "restock") $(widgetFile "restock")
getUpstockR :: BeverageId -> Handler Html getUpstockR :: BeverageId -> Handler Html
getUpstockR bId = do getUpstockR bId =
mBev <- runDB $ get bId isBeverage bId RestockR >>= (\bev -> do
case mBev of (upstockWidget, enctype) <- generateFormPost
Just bev -> do $ renderBootstrap3 BootstrapBasicForm upstockForm
(upstockWidget, enctype) <- generateFormPost defaultLayout $
$ renderBootstrap3 BootstrapBasicForm upstockForm $(widgetFile "upstock")
defaultLayout $ )
$(widgetFile "upstock")
Nothing -> do
setMessageI MsgItemUnknown
redirect RestockR
postUpstockR :: BeverageId -> Handler Html postUpstockR :: BeverageId -> Handler Html
postUpstockR bId = do postUpstockR bId =
mBev <- runDB $ get bId isBeverage bId RestockR >>= (\bev -> do
case mBev of ((res, _), _) <- runFormPost
Just bev -> do $ renderBootstrap3 BootstrapBasicForm upstockForm
((res, _), _) <- runFormPost case res of
$ renderBootstrap3 BootstrapBasicForm upstockForm FormSuccess c ->
case res of if upstockSingles c >= 0 && upstockCrates c >= 0
FormSuccess c -> then do
if upstockSingles c >= 0 && upstockCrates c >= 0 let total = upstockSingles c + (upstockCrates c * (fromMaybe 0 $ beveragePerCrate bev))
then do runDB $ update bId [BeverageAmount +=. total]
let total = upstockSingles c + (upstockCrates c * (fromMaybe 0 $ beveragePerCrate bev)) setMessageI MsgStockedUp
runDB $ update bId [BeverageAmount +=. total] redirect RestockR
setMessageI MsgStockedUp else do
redirect RestockR setMessageI MsgNotStockedUp
else do redirect $ UpstockR bId
setMessageI MsgNotStockedUp
redirect $ UpstockR bId _ -> do
setMessageI MsgStockupError
_ -> do redirect $ UpstockR bId
setMessageI MsgStockupError )
redirect $ UpstockR bId
Nothing -> do
setMessageI MsgItemUnknown
redirect RestockR
data UpstockAmount = UpstockAmount data UpstockAmount = UpstockAmount
{ upstockSingles :: Int { upstockSingles :: Int

82
Handler/Select.hs
View file

@ -21,17 +21,13 @@ import qualified Data.Text as T
import Data.Maybe import Data.Maybe
getSelectR :: UserId -> Handler Html getSelectR :: UserId -> Handler Html
getSelectR uId = do getSelectR uId =
mUser <- runDB $ get uId isUser uId HomeR >>= (\user -> do
case mUser of master <- getYesod
Just user -> do beverages <- runDB $ selectList [BeverageAmount >. 0] [Asc BeverageIdent]
master <- getYesod defaultLayout $
beverages <- runDB $ selectList [BeverageAmount >. 0] [Asc BeverageIdent] $(widgetFile "select")
defaultLayout $ )
$(widgetFile "select")
Nothing -> do
setMessageI MsgUserUnknown
redirect HomeR
getSelectCashR :: Handler Html getSelectCashR :: Handler Html
getSelectCashR = do getSelectCashR = do
@ -40,44 +36,36 @@ getSelectCashR = do
$(widgetFile "selectCash") $(widgetFile "selectCash")
getRechargeR :: UserId -> Handler Html getRechargeR :: UserId -> Handler Html
getRechargeR uId = do getRechargeR uId =
mUser <- runDB $ get uId isUser uId HomeR >>= (\user -> do
case mUser of (rechargeWidget, enctype) <- generateFormPost
Just user -> do $ renderBootstrap3 BootstrapBasicForm rechargeForm
(rechargeWidget, enctype) <- generateFormPost currency <- appCurrency <$> appSettings <$> getYesod
$ renderBootstrap3 BootstrapBasicForm rechargeForm defaultLayout $
currency <- appCurrency <$> appSettings <$> getYesod $(widgetFile "recharge")
defaultLayout $ )
$(widgetFile "recharge")
Nothing -> do
setMessageI MsgUserUnknown
redirect HomeR
postRechargeR :: UserId -> Handler Html postRechargeR :: UserId -> Handler Html
postRechargeR uId = do postRechargeR uId =
mUser <- runDB $ get uId isUser uId HomeR >>= (\user -> do
case mUser of ((res, _), _) <- runFormPost
Just user -> do $ renderBootstrap3 BootstrapBasicForm rechargeForm
((res, _), _) <- runFormPost case res of
$ renderBootstrap3 BootstrapBasicForm rechargeForm FormSuccess amount ->
case res of if amount < 0
FormSuccess amount -> then do
if amount < 0 setMessageI MsgNegativeRecharge
then do redirect $ RechargeR uId
setMessageI MsgNegativeRecharge else do
redirect $ RechargeR uId updateCashier amount ("Guthaben: " `T.append` userIdent user)
else do today <- liftIO $ return . utctDay =<< getCurrentTime
updateCashier amount ("Guthaben: " `T.append` userIdent user) runDB $ update uId [UserBalance +=. amount, UserTimestamp =. today]
today <- liftIO $ return . utctDay =<< getCurrentTime setMessageI MsgRecharged
runDB $ update uId [UserBalance +=. amount, UserTimestamp =. today] redirect HomeR
setMessageI MsgRecharged _ -> do
redirect HomeR setMessageI MsgRechargeError
_ -> do redirect HomeR
setMessageI MsgRechargeError )
redirect HomeR
Nothing -> do
setMessageI MsgUserUnknown
redirect HomeR
rechargeForm :: AForm Handler Int rechargeForm :: AForm Handler Int
rechargeForm = areq currencyField (bfs MsgValue) (Just 0) rechargeForm = areq currencyField (bfs MsgValue) (Just 0)

96
Handler/Transfer.hs
View file

@ -21,69 +21,49 @@ import Data.Maybe
import Text.Shakespeare.Text (stext) import Text.Shakespeare.Text (stext)
getTransferSelectR :: UserId -> Handler Html getTransferSelectR :: UserId -> Handler Html
getTransferSelectR from = do getTransferSelectR from =
mUser <- runDB $ get from isUser from HomeR >>= (\_ -> do
case mUser of users <- runDB $ selectList [UserId !=. from] [Asc UserIdent]
Just _ -> do defaultLayout $
users <- runDB $ selectList [UserId !=. from] [Asc UserIdent] $(widgetFile "transferSelect")
defaultLayout $ )
$(widgetFile "transferSelect")
Nothing -> do
setMessageI MsgUserUnknown
redirect HomeR
getTransferR :: UserId -> UserId -> Handler Html getTransferR :: UserId -> UserId -> Handler Html
getTransferR from to = do getTransferR from to =
mSender <- runDB $ get from isUser from HomeR >>= (\sender ->
case mSender of isUser to (TransferSelectR from) >>= (\recpt -> do
Just sender -> do (transferWidget, enctype) <- generateFormPost
mRecpt <- runDB $ get to $ renderBootstrap3 BootstrapBasicForm transferForm
case mRecpt of currency <- appCurrency <$> appSettings <$> getYesod
Just recpt -> do defaultLayout $ do
(transferWidget, enctype) <- generateFormPost $(widgetFile "transfer")
$ renderBootstrap3 BootstrapBasicForm 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 :: UserId -> UserId -> Handler Html
postTransferR from to = do postTransferR from to =
mSender <- runDB $ get from isUser from HomeR >>= (\sender ->
case mSender of isUser to (TransferSelectR from) >>= (\recpt -> do
Just sender -> do ((res, _), _) <- runFormPost
mRecpt <- runDB $ get to $ renderBootstrap3 BootstrapBasicForm transferForm
case mRecpt of case res of
Just recpt -> do FormSuccess amount -> do
((res, _), _) <- runFormPost if amount < 0
$ renderBootstrap3 BootstrapBasicForm transferForm then do
case res of setMessageI MsgNegativeTransfer
FormSuccess amount -> do redirect $ TransferR from to
if amount < 0 else do
then do runDB $ update from [UserBalance -=. amount]
setMessageI MsgNegativeTransfer runDB $ update to [UserBalance +=. amount]
redirect $ TransferR from to master <- getYesod
else do liftIO $ notify sender recpt amount master
runDB $ update from [UserBalance -=. amount] setMessageI MsgTransferComplete
runDB $ update to [UserBalance +=. amount]
master <- getYesod
liftIO $ notify sender recpt amount master
setMessageI MsgTransferComplete
redirect HomeR
_ -> do
setMessageI MsgTransferError
redirect HomeR redirect HomeR
Nothing -> do _ -> do
setMessageI MsgUserUnknown setMessageI MsgTransferError
redirect $ TransferSelectR from redirect HomeR
Nothing -> do )
setMessageI MsgUserUnknown )
redirect HomeR
transferForm :: AForm Handler Int transferForm :: AForm Handler Int
transferForm = areq currencyField (bfs MsgValue) (Just 0) transferForm = areq currencyField (bfs MsgValue) (Just 0)