deduplication

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

View file

@ -21,24 +21,17 @@ 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
Just (_, bev) -> do
master <- getYesod master <- getYesod
(buyWidget, enctype) <- generateFormPost (buyWidget, enctype) <- generateFormPost
$ renderBootstrap3 BootstrapBasicForm $ renderBootstrap3 BootstrapBasicForm
$ buyForm $ buyForm
defaultLayout $ defaultLayout $
$(widgetFile "buy") $(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
Just (user, bev) -> do
((res, _), _) <- runFormPost ((res, _), _) <- runFormPost
$ renderBootstrap3 BootstrapBasicForm $ renderBootstrap3 BootstrapBasicForm
$ buyForm $ buyForm
@ -73,9 +66,6 @@ postBuyR uId bId = do
_ -> do _ -> do
setMessageI MsgErrorOccured setMessageI MsgErrorOccured
redirect HomeR redirect HomeR
Nothing -> do
setMessageI MsgUserUnknown
redirect HomeR
notifyUser :: User -> Beverage -> Int -> Int -> App -> IO () notifyUser :: User -> Beverage -> Int -> Int -> App -> IO ()
notifyUser user bev quant price master = do notifyUser user bev quant price master = do
@ -121,10 +111,8 @@ 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
Just bev -> do
((res, _), _) <- runFormPost ((res, _), _) <- runFormPost
$ renderBootstrap3 BootstrapBasicForm $ renderBootstrap3 BootstrapBasicForm
$ buyForm $ buyForm
@ -146,20 +134,15 @@ postBuyCashR bId = do
_ -> do _ -> do
setMessageI MsgItemDisappeared setMessageI MsgItemDisappeared
redirect HomeR 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)

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

View file

@ -19,10 +19,8 @@ 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
Just bev -> do
p <- lookupGetParam "barcode" p <- lookupGetParam "barcode"
_ <- handleGetParam p (Right bId) _ <- handleGetParam p (Right bId)
rawbs <- runDB $ selectList [BarcodeBev ==. Just bId] [] rawbs <- runDB $ selectList [BarcodeBev ==. Just bId] []
@ -32,15 +30,11 @@ getModifyR bId = do
$ modifyForm bev bs $ modifyForm bev bs
defaultLayout $ defaultLayout $
$(widgetFile "modify") $(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
Just bev -> do
rawbs <- runDB $ selectList [BarcodeBev ==. Just bId] [] rawbs <- runDB $ selectList [BarcodeBev ==. Just bId] []
let bs = map (barcodeCode . entityVal) rawbs let bs = map (barcodeCode . entityVal) rawbs
((res, _), _) <- runFormPost ((res, _), _) <- runFormPost
@ -68,9 +62,7 @@ postModifyR bId = do
_ -> do _ -> do
setMessageI MsgEditFail setMessageI MsgEditFail
redirect SummaryR 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
Just _ -> do
runDB $ delete bId runDB $ delete bId
setMessageI MsgItemDeleted setMessageI MsgItemDeleted
redirect HomeR redirect HomeR
Nothing -> do )
setMessageI MsgItemUnknown
redirect HomeR

View file

@ -70,10 +70,8 @@ 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
Just user -> do
p <- lookupGetParam "barcode" p <- lookupGetParam "barcode"
_ <- handleGetParam p (Left uId) _ <- handleGetParam p (Left uId)
rawbs <- runDB $ selectList [BarcodeUser ==. Just uId] [] rawbs <- runDB $ selectList [BarcodeUser ==. Just uId] []
@ -83,15 +81,11 @@ getModifyUserR uId = do
$ modifyUserForm user bs $ modifyUserForm user bs
defaultLayout $ defaultLayout $
$(widgetFile "modifyUser") $(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
Just user -> do
rawbs <- runDB $ selectList [BarcodeUser ==. Just uId] [] rawbs <- runDB $ selectList [BarcodeUser ==. Just uId] []
let bs = map (barcodeCode . entityVal) rawbs let bs = map (barcodeCode . entityVal) rawbs
((res, _), _) <- runFormPost ((res, _), _) <- runFormPost
@ -117,9 +111,7 @@ postModifyUserR uId = do
_ -> do _ -> do
setMessageI MsgUserNotEdited setMessageI MsgUserNotEdited
redirect $ SelectR uId 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

View file

@ -26,23 +26,17 @@ 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
Just bev -> do
(upstockWidget, enctype) <- generateFormPost (upstockWidget, enctype) <- generateFormPost
$ renderBootstrap3 BootstrapBasicForm upstockForm $ renderBootstrap3 BootstrapBasicForm upstockForm
defaultLayout $ defaultLayout $
$(widgetFile "upstock") $(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
Just bev -> do
((res, _), _) <- runFormPost ((res, _), _) <- runFormPost
$ renderBootstrap3 BootstrapBasicForm upstockForm $ renderBootstrap3 BootstrapBasicForm upstockForm
case res of case res of
@ -60,9 +54,7 @@ postUpstockR bId = do
_ -> do _ -> do
setMessageI MsgStockupError setMessageI MsgStockupError
redirect $ UpstockR bId redirect $ UpstockR bId
Nothing -> do )
setMessageI MsgItemUnknown
redirect RestockR
data UpstockAmount = UpstockAmount data UpstockAmount = UpstockAmount
{ upstockSingles :: Int { upstockSingles :: Int

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
Just user -> do
master <- getYesod master <- getYesod
beverages <- runDB $ selectList [BeverageAmount >. 0] [Asc BeverageIdent] beverages <- runDB $ selectList [BeverageAmount >. 0] [Asc BeverageIdent]
defaultLayout $ defaultLayout $
$(widgetFile "select") $(widgetFile "select")
Nothing -> do )
setMessageI MsgUserUnknown
redirect HomeR
getSelectCashR :: Handler Html getSelectCashR :: Handler Html
getSelectCashR = do getSelectCashR = do
@ -40,24 +36,18 @@ 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
Just user -> do
(rechargeWidget, enctype) <- generateFormPost (rechargeWidget, enctype) <- generateFormPost
$ renderBootstrap3 BootstrapBasicForm rechargeForm $ renderBootstrap3 BootstrapBasicForm rechargeForm
currency <- appCurrency <$> appSettings <$> getYesod currency <- appCurrency <$> appSettings <$> getYesod
defaultLayout $ defaultLayout $
$(widgetFile "recharge") $(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
Just user -> do
((res, _), _) <- runFormPost ((res, _), _) <- runFormPost
$ renderBootstrap3 BootstrapBasicForm rechargeForm $ renderBootstrap3 BootstrapBasicForm rechargeForm
case res of case res of
@ -75,9 +65,7 @@ postRechargeR uId = do
_ -> do _ -> do
setMessageI MsgRechargeError setMessageI MsgRechargeError
redirect HomeR 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)

View file

@ -21,45 +21,29 @@ 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
Just _ -> do
users <- runDB $ selectList [UserId !=. from] [Asc UserIdent] users <- runDB $ selectList [UserId !=. from] [Asc UserIdent]
defaultLayout $ defaultLayout $
$(widgetFile "transferSelect") $(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
mRecpt <- runDB $ get to
case mRecpt of
Just recpt -> do
(transferWidget, enctype) <- generateFormPost (transferWidget, enctype) <- generateFormPost
$ renderBootstrap3 BootstrapBasicForm transferForm $ renderBootstrap3 BootstrapBasicForm transferForm
currency <- appCurrency <$> appSettings <$> getYesod currency <- appCurrency <$> appSettings <$> getYesod
defaultLayout $ do defaultLayout $ do
$(widgetFile "transfer") $(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
mRecpt <- runDB $ get to
case mRecpt of
Just recpt -> do
((res, _), _) <- runFormPost ((res, _), _) <- runFormPost
$ renderBootstrap3 BootstrapBasicForm transferForm $ renderBootstrap3 BootstrapBasicForm transferForm
case res of case res of
@ -78,12 +62,8 @@ postTransferR from to = do
_ -> do _ -> do
setMessageI MsgTransferError setMessageI MsgTransferError
redirect HomeR redirect HomeR
Nothing -> do )
setMessageI MsgUserUnknown )
redirect $ TransferSelectR from
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)