diff --git a/Handler/Buy.hs b/Handler/Buy.hs index 590f4c1..ccc2b75 100644 --- a/Handler/Buy.hs +++ b/Handler/Buy.hs @@ -21,60 +21,50 @@ import Text.Shakespeare.Text getBuyR :: UserId -> BeverageId -> Handler Html getBuyR uId bId = do - mTup <- checkData uId bId - case mTup of - Just (_, bev) -> do - master <- getYesod - (buyWidget, enctype) <- generateFormPost - $ renderBootstrap3 BootstrapBasicForm - $ buyForm - defaultLayout $ - $(widgetFile "buy") - Nothing -> do - setMessageI MsgUserOrArticleUnknown - redirect HomeR + (_, bev) <- checkData uId bId + master <- getYesod + (buyWidget, enctype) <- generateFormPost + $ renderBootstrap3 BootstrapBasicForm + $ buyForm + defaultLayout $ + $(widgetFile "buy") postBuyR :: UserId -> BeverageId -> Handler Html postBuyR uId bId = do - mTup <- checkData uId bId - case mTup of - Just (user, bev) -> do - ((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] - checkAlert bId - master <- getYesod - liftIO $ notifyUser user bev quant price master - case sw of - False -> do - setMessageI MsgPurchaseSuccess - redirect HomeR - True -> do - let level = case userBalance user - price of - balance - | balance <= -5000 -> 3 - | balance <= -1000 -> 2 - | otherwise -> 1 - redirect $ DemandR level - _ -> do - setMessageI MsgErrorOccured - redirect HomeR - Nothing -> do - setMessageI MsgUserUnknown + (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] + checkAlert bId + master <- getYesod + liftIO $ notifyUser user bev quant price master + case sw of + False -> do + setMessageI MsgPurchaseSuccess + redirect HomeR + True -> do + let level = case userBalance user - price of + balance + | balance <= -5000 -> 3 + | balance <= -1000 -> 2 + | otherwise -> 1 + redirect $ DemandR level + _ -> do + setMessageI MsgErrorOccured redirect HomeR notifyUser :: User -> Beverage -> Int -> Int -> App -> IO () @@ -121,45 +111,38 @@ getBuyCashR bId = do redirect HomeR postBuyCashR :: BeverageId -> Handler Html -postBuyCashR bId = do - mBev <- runDB $ get bId - case mBev of - Just 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 - let currency = appCurrency $ appSettings master - setMessageI $ MsgPurchaseSuccessCash price currency - redirect HomeR - _ -> do - setMessageI MsgItemDisappeared - redirect HomeR - Nothing -> do - setMessageI MsgItemUnknown - redirect HomeR +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 + let currency = appCurrency $ appSettings master + setMessageI $ MsgPurchaseSuccessCash price currency + redirect HomeR + _ -> do + setMessageI MsgItemDisappeared + 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 +checkData :: UserId -> BeverageId -> Handler (User, Beverage) +checkData uId bId = + isUser uId HomeR >>= (\user -> do + isBeverage bId HomeR >>= (\bev -> + return (user, bev) + ) + ) buyForm :: AForm Handler Int buyForm = areq amountField (bfs MsgAmount) (Just 1) diff --git a/Handler/Common.hs b/Handler/Common.hs index 7b7a449..2d83312 100644 --- a/Handler/Common.hs +++ b/Handler/Common.hs @@ -223,3 +223,27 @@ sendMail to subject body = formatIntVolume :: Int -> Text 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 diff --git a/Handler/Modify.hs b/Handler/Modify.hs index ab991e5..86cb04b 100644 --- a/Handler/Modify.hs +++ b/Handler/Modify.hs @@ -19,58 +19,50 @@ import Import import Handler.Common getModifyR :: BeverageId -> Handler Html -getModifyR bId = do - mBev <- runDB $ get bId - case mBev of - Just bev -> do - p <- lookupGetParam "barcode" - _ <- handleGetParam p (Right bId) - rawbs <- runDB $ selectList [BarcodeBev ==. Just bId] [] - let bs = map (barcodeCode . entityVal) rawbs - (modifyWidget, enctype) <- generateFormPost - $ renderBootstrap3 BootstrapBasicForm - $ modifyForm bev bs - defaultLayout $ - $(widgetFile "modify") - Nothing -> do - setMessageI MsgItemUnknown - redirect SummaryR +getModifyR bId = + isBeverage bId SummaryR >>= (\bev -> do + p <- lookupGetParam "barcode" + _ <- handleGetParam p (Right bId) + rawbs <- runDB $ selectList [BarcodeBev ==. Just bId] [] + let bs = map (barcodeCode . entityVal) rawbs + (modifyWidget, enctype) <- generateFormPost + $ renderBootstrap3 BootstrapBasicForm + $ modifyForm bev bs + defaultLayout $ + $(widgetFile "modify") + ) postModifyR :: BeverageId -> Handler Html -postModifyR bId = do - mBev <- runDB $ get bId - case mBev of - Just bev -> do - rawbs <- runDB $ selectList [BarcodeBev ==. Just bId] [] - let bs = map (barcodeCode . entityVal) rawbs - ((res, _), _) <- runFormPost - $ renderBootstrap3 BootstrapBasicForm - $ modifyForm bev bs - case res of - FormSuccess nBev -> do - runDB $ update bId - [ BeverageIdent =. modBevIdent nBev - , BeveragePrice =. modBevPrice nBev - , BeverageAmount =. modBevAmount nBev - , BeverageAlertAmount =. modBevAlertAmount nBev - , BeverageCorrectedAmount +=. (modBevAmount nBev - beverageAmount bev) - , BeverageMl =. modBevMl nBev - , BeverageAvatar =. modBevAvatar nBev - , BeverageSupplier =. modBevSupp nBev - , BeverageMaxAmount =. modBevMaxAmount nBev - , BeveragePerCrate =. modBevPC nBev - , BeverageArtNr =. modBevArtNr nBev - , BeveragePricePerCrate =. modBevPricePC nBev - ] - handleBarcodes (Right bId) (fromMaybe [] $ modBevBarcodes nBev) - setMessageI MsgEditSuccess - redirect SummaryR - _ -> do - setMessageI MsgEditFail - redirect SummaryR - Nothing -> do - setMessageI MsgItemUnknown - redirect SummaryR +postModifyR bId = + isBeverage bId SummaryR >>= (\bev -> do + rawbs <- runDB $ selectList [BarcodeBev ==. Just bId] [] + let bs = map (barcodeCode . entityVal) rawbs + ((res, _), _) <- runFormPost + $ renderBootstrap3 BootstrapBasicForm + $ modifyForm bev bs + case res of + FormSuccess nBev -> do + runDB $ update bId + [ BeverageIdent =. modBevIdent nBev + , BeveragePrice =. modBevPrice nBev + , BeverageAmount =. modBevAmount nBev + , BeverageAlertAmount =. modBevAlertAmount nBev + , BeverageCorrectedAmount +=. (modBevAmount nBev - beverageAmount bev) + , BeverageMl =. modBevMl nBev + , BeverageAvatar =. modBevAvatar nBev + , BeverageSupplier =. modBevSupp nBev + , BeverageMaxAmount =. modBevMaxAmount nBev + , BeveragePerCrate =. modBevPC nBev + , BeverageArtNr =. modBevArtNr nBev + , BeveragePricePerCrate =. modBevPricePC nBev + ] + handleBarcodes (Right bId) (fromMaybe [] $ modBevBarcodes nBev) + setMessageI MsgEditSuccess + redirect SummaryR + _ -> do + setMessageI MsgEditFail + redirect SummaryR + ) data ModBev = ModBev { modBevIdent :: Text @@ -107,13 +99,9 @@ modifyForm bev bs = ModBev sups = optionsPersistKey [] [Asc SupplierIdent] supplierIdent getDeleteBeverageR :: BeverageId -> Handler Html -getDeleteBeverageR bId = do - mBev <- runDB $ get bId - case mBev of - Just _ -> do - runDB $ delete bId - setMessageI MsgItemDeleted - redirect HomeR - Nothing -> do - setMessageI MsgItemUnknown - redirect HomeR +getDeleteBeverageR bId = + isBeverage bId HomeR >>= (\_ -> do + runDB $ delete bId + setMessageI MsgItemDeleted + redirect HomeR + ) diff --git a/Handler/NewUser.hs b/Handler/NewUser.hs index d7e2e50..9085297 100644 --- a/Handler/NewUser.hs +++ b/Handler/NewUser.hs @@ -70,56 +70,48 @@ data UserConf = UserConf } getModifyUserR :: UserId -> Handler Html -getModifyUserR uId = do - mUser <- runDB $ I.get uId - case mUser of - Just user -> do - p <- lookupGetParam "barcode" - _ <- handleGetParam p (Left uId) - rawbs <- runDB $ selectList [BarcodeUser ==. Just uId] [] - let bs = map (barcodeCode . entityVal) rawbs - (modifyUserWidget, enctype) <- generateFormPost - $ renderBootstrap3 BootstrapBasicForm - $ modifyUserForm user bs - defaultLayout $ - $(widgetFile "modifyUser") - Nothing -> do - setMessageI MsgUserUnknown - redirect HomeR +getModifyUserR uId = + isUser uId HomeR >>= (\user -> do + p <- lookupGetParam "barcode" + _ <- handleGetParam p (Left uId) + rawbs <- runDB $ selectList [BarcodeUser ==. Just uId] [] + let bs = map (barcodeCode . entityVal) rawbs + (modifyUserWidget, enctype) <- generateFormPost + $ renderBootstrap3 BootstrapBasicForm + $ modifyUserForm user bs + defaultLayout $ + $(widgetFile "modifyUser") + ) postModifyUserR :: UserId -> Handler Html -postModifyUserR uId = do - mUser <- runDB $ I.get uId - case mUser of - Just user -> do - rawbs <- runDB $ selectList [BarcodeUser ==. Just uId] [] - let bs = map (barcodeCode . entityVal) rawbs - ((res, _), _) <- runFormPost - $ renderBootstrap3 BootstrapBasicForm - $ modifyUserForm user bs - case res of - FormSuccess uc -> do - namesakes <- runDB $ selectList [UserIdent ==. userConfIdent uc, UserId !=. uId] [] - if null namesakes - then do - runDB $ update uId - [ UserIdent =. userConfIdent uc - , UserEmail =. userConfEmail uc - , UserAvatar =. userConfAvatar uc - ] - liftIO $ notify user (userConfEmail uc) - handleBarcodes (Left uId) (fromMaybe [] $ userConfBarcode uc) - setMessageI MsgUserEdited - redirect $ SelectR uId - else do - setMessageI MsgUserIdentNotUnique - redirect $ ModifyUserR uId - _ -> do - setMessageI MsgUserNotEdited - redirect $ SelectR uId - Nothing -> do - setMessageI MsgUserUnknown - redirect HomeR +postModifyUserR uId = + isUser uId HomeR >>= (\user -> do + rawbs <- runDB $ selectList [BarcodeUser ==. Just uId] [] + let bs = map (barcodeCode . entityVal) rawbs + ((res, _), _) <- runFormPost + $ renderBootstrap3 BootstrapBasicForm + $ modifyUserForm user bs + case res of + FormSuccess uc -> do + namesakes <- runDB $ selectList [UserIdent ==. userConfIdent uc, UserId !=. uId] [] + if null namesakes + then do + runDB $ update uId + [ UserIdent =. userConfIdent uc + , UserEmail =. userConfEmail uc + , UserAvatar =. userConfAvatar uc + ] + liftIO $ notify user (userConfEmail uc) + handleBarcodes (Left uId) (fromMaybe [] $ userConfBarcode uc) + setMessageI MsgUserEdited + redirect $ SelectR uId + else do + setMessageI MsgUserIdentNotUnique + redirect $ ModifyUserR uId + _ -> do + setMessageI MsgUserNotEdited + redirect $ SelectR uId + ) modifyUserForm :: User -> [Text] -> AForm Handler UserConf modifyUserForm user bs = UserConf diff --git a/Handler/Restock.hs b/Handler/Restock.hs index 8b35aee..12b9130 100644 --- a/Handler/Restock.hs +++ b/Handler/Restock.hs @@ -26,43 +26,35 @@ getRestockR = do $(widgetFile "restock") getUpstockR :: BeverageId -> Handler Html -getUpstockR bId = do - mBev <- runDB $ get bId - case mBev of - Just bev -> do - (upstockWidget, enctype) <- generateFormPost - $ renderBootstrap3 BootstrapBasicForm upstockForm - defaultLayout $ - $(widgetFile "upstock") - Nothing -> do - setMessageI MsgItemUnknown - redirect RestockR +getUpstockR bId = + isBeverage bId RestockR >>= (\bev -> do + (upstockWidget, enctype) <- generateFormPost + $ renderBootstrap3 BootstrapBasicForm upstockForm + defaultLayout $ + $(widgetFile "upstock") + ) postUpstockR :: BeverageId -> Handler Html -postUpstockR bId = do - mBev <- runDB $ get bId - case mBev of - Just bev -> do - ((res, _), _) <- runFormPost - $ renderBootstrap3 BootstrapBasicForm upstockForm - case res of - FormSuccess c -> - if upstockSingles c >= 0 && upstockCrates c >= 0 - then do - let total = upstockSingles c + (upstockCrates c * (fromMaybe 0 $ beveragePerCrate bev)) - runDB $ update bId [BeverageAmount +=. total] - setMessageI MsgStockedUp - redirect RestockR - else do - setMessageI MsgNotStockedUp - redirect $ UpstockR bId - - _ -> do - setMessageI MsgStockupError - redirect $ UpstockR bId - Nothing -> do - setMessageI MsgItemUnknown - redirect RestockR +postUpstockR bId = + isBeverage bId RestockR >>= (\bev -> do + ((res, _), _) <- runFormPost + $ renderBootstrap3 BootstrapBasicForm upstockForm + case res of + FormSuccess c -> + if upstockSingles c >= 0 && upstockCrates c >= 0 + then do + let total = upstockSingles c + (upstockCrates c * (fromMaybe 0 $ beveragePerCrate bev)) + runDB $ update bId [BeverageAmount +=. total] + setMessageI MsgStockedUp + redirect RestockR + else do + setMessageI MsgNotStockedUp + redirect $ UpstockR bId + + _ -> do + setMessageI MsgStockupError + redirect $ UpstockR bId + ) data UpstockAmount = UpstockAmount { upstockSingles :: Int diff --git a/Handler/Select.hs b/Handler/Select.hs index b88a832..310c165 100644 --- a/Handler/Select.hs +++ b/Handler/Select.hs @@ -21,17 +21,13 @@ import qualified Data.Text as T import Data.Maybe getSelectR :: UserId -> Handler Html -getSelectR uId = do - mUser <- runDB $ get uId - case mUser of - Just user -> do - master <- getYesod - beverages <- runDB $ selectList [BeverageAmount >. 0] [Asc BeverageIdent] - defaultLayout $ - $(widgetFile "select") - Nothing -> do - setMessageI MsgUserUnknown - redirect HomeR +getSelectR uId = + isUser uId HomeR >>= (\user -> do + master <- getYesod + beverages <- runDB $ selectList [BeverageAmount >. 0] [Asc BeverageIdent] + defaultLayout $ + $(widgetFile "select") + ) getSelectCashR :: Handler Html getSelectCashR = do @@ -40,44 +36,36 @@ getSelectCashR = do $(widgetFile "selectCash") getRechargeR :: UserId -> Handler Html -getRechargeR uId = do - mUser <- runDB $ get uId - case mUser of - Just user -> do - (rechargeWidget, enctype) <- generateFormPost - $ renderBootstrap3 BootstrapBasicForm rechargeForm - currency <- appCurrency <$> appSettings <$> getYesod - defaultLayout $ - $(widgetFile "recharge") - Nothing -> do - setMessageI MsgUserUnknown - redirect HomeR +getRechargeR uId = + isUser uId HomeR >>= (\user -> do + (rechargeWidget, enctype) <- generateFormPost + $ renderBootstrap3 BootstrapBasicForm rechargeForm + currency <- appCurrency <$> appSettings <$> getYesod + defaultLayout $ + $(widgetFile "recharge") + ) postRechargeR :: UserId -> Handler Html -postRechargeR uId = do - mUser <- runDB $ get uId - case mUser of - Just user -> do - ((res, _), _) <- runFormPost - $ renderBootstrap3 BootstrapBasicForm rechargeForm - case res of - FormSuccess amount -> - if amount < 0 - then do - setMessageI MsgNegativeRecharge - redirect $ RechargeR uId - else do - updateCashier amount ("Guthaben: " `T.append` userIdent user) - today <- liftIO $ return . utctDay =<< getCurrentTime - runDB $ update uId [UserBalance +=. amount, UserTimestamp =. today] - setMessageI MsgRecharged - redirect HomeR - _ -> do - setMessageI MsgRechargeError - redirect HomeR - Nothing -> do - setMessageI MsgUserUnknown - redirect HomeR +postRechargeR uId = + isUser uId HomeR >>= (\user -> do + ((res, _), _) <- runFormPost + $ renderBootstrap3 BootstrapBasicForm rechargeForm + case res of + FormSuccess amount -> + if amount < 0 + then do + setMessageI MsgNegativeRecharge + redirect $ RechargeR uId + else do + updateCashier amount ("Guthaben: " `T.append` userIdent user) + today <- liftIO $ return . utctDay =<< getCurrentTime + runDB $ update uId [UserBalance +=. amount, UserTimestamp =. today] + setMessageI MsgRecharged + redirect HomeR + _ -> do + setMessageI MsgRechargeError + redirect HomeR + ) rechargeForm :: AForm Handler Int rechargeForm = areq currencyField (bfs MsgValue) (Just 0) diff --git a/Handler/Transfer.hs b/Handler/Transfer.hs index 7442634..c14d7b8 100644 --- a/Handler/Transfer.hs +++ b/Handler/Transfer.hs @@ -21,69 +21,49 @@ import Data.Maybe import Text.Shakespeare.Text (stext) getTransferSelectR :: UserId -> Handler Html -getTransferSelectR from = do - mUser <- runDB $ get from - case mUser of - Just _ -> do - users <- runDB $ selectList [UserId !=. from] [Asc UserIdent] - defaultLayout $ - $(widgetFile "transferSelect") - Nothing -> do - setMessageI MsgUserUnknown - redirect HomeR +getTransferSelectR from = + isUser from HomeR >>= (\_ -> do + users <- runDB $ selectList [UserId !=. from] [Asc UserIdent] + defaultLayout $ + $(widgetFile "transferSelect") + ) 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 - $ renderBootstrap3 BootstrapBasicForm transferForm - currency <- appCurrency <$> appSettings <$> getYesod - defaultLayout $ do - $(widgetFile "transfer") - Nothing -> do - setMessageI MsgUserUnknown - redirect $ TransferSelectR from - Nothing -> do - setMessageI MsgUserUnknown - redirect HomeR +getTransferR from to = + isUser from HomeR >>= (\sender -> + isUser to (TransferSelectR from) >>= (\recpt -> do + (transferWidget, enctype) <- generateFormPost + $ renderBootstrap3 BootstrapBasicForm transferForm + currency <- appCurrency <$> appSettings <$> getYesod + defaultLayout $ do + $(widgetFile "transfer") + ) + ) 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 - $ renderBootstrap3 BootstrapBasicForm transferForm - case res of - FormSuccess amount -> do - if amount < 0 - then do - setMessageI MsgNegativeTransfer - redirect $ TransferR from to - else do - runDB $ update from [UserBalance -=. amount] - runDB $ update to [UserBalance +=. amount] - master <- getYesod - liftIO $ notify sender recpt amount master - setMessageI MsgTransferComplete - redirect HomeR - _ -> do - setMessageI MsgTransferError +postTransferR from to = + isUser from HomeR >>= (\sender -> + isUser to (TransferSelectR from) >>= (\recpt -> do + ((res, _), _) <- runFormPost + $ renderBootstrap3 BootstrapBasicForm transferForm + case res of + FormSuccess amount -> do + if amount < 0 + then do + setMessageI MsgNegativeTransfer + redirect $ TransferR from to + else do + runDB $ update from [UserBalance -=. amount] + runDB $ update to [UserBalance +=. amount] + master <- getYesod + liftIO $ notify sender recpt amount master + setMessageI MsgTransferComplete redirect HomeR - Nothing -> do - setMessageI MsgUserUnknown - redirect $ TransferSelectR from - Nothing -> do - setMessageI MsgUserUnknown - redirect HomeR + _ -> do + setMessageI MsgTransferError + redirect HomeR + ) + ) transferForm :: AForm Handler Int transferForm = areq currencyField (bfs MsgValue) (Just 0)