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 uId bId = do
mTup <- checkData uId bId
case mTup of
Just (_, bev) -> do
(_, bev) <- checkData uId bId
master <- getYesod
(buyWidget, enctype) <- generateFormPost
$ renderBootstrap3 BootstrapBasicForm
$ buyForm
defaultLayout $
$(widgetFile "buy")
Nothing -> do
setMessageI MsgUserOrArticleUnknown
redirect HomeR
postBuyR :: UserId -> BeverageId -> Handler Html
postBuyR uId bId = do
mTup <- checkData uId bId
case mTup of
Just (user, bev) -> do
(user, bev) <- checkData uId bId
((res, _), _) <- runFormPost
$ renderBootstrap3 BootstrapBasicForm
$ buyForm
@ -73,9 +66,6 @@ postBuyR uId bId = do
_ -> do
setMessageI MsgErrorOccured
redirect HomeR
Nothing -> do
setMessageI MsgUserUnknown
redirect HomeR
notifyUser :: User -> Beverage -> Int -> Int -> App -> IO ()
notifyUser user bev quant price master = do
@ -121,10 +111,8 @@ getBuyCashR bId = do
redirect HomeR
postBuyCashR :: BeverageId -> Handler Html
postBuyCashR bId = do
mBev <- runDB $ get bId
case mBev of
Just bev -> do
postBuyCashR bId =
isBeverage bId HomeR >>= (\bev -> do
((res, _), _) <- runFormPost
$ renderBootstrap3 BootstrapBasicForm
$ buyForm
@ -146,20 +134,15 @@ postBuyCashR bId = do
_ -> do
setMessageI MsgItemDisappeared
redirect HomeR
Nothing -> do
setMessageI MsgItemUnknown
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)

View file

@ -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

View file

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

View file

@ -70,10 +70,8 @@ data UserConf = UserConf
}
getModifyUserR :: UserId -> Handler Html
getModifyUserR uId = do
mUser <- runDB $ I.get uId
case mUser of
Just user -> do
getModifyUserR uId =
isUser uId HomeR >>= (\user -> do
p <- lookupGetParam "barcode"
_ <- handleGetParam p (Left uId)
rawbs <- runDB $ selectList [BarcodeUser ==. Just uId] []
@ -83,15 +81,11 @@ getModifyUserR uId = do
$ modifyUserForm user bs
defaultLayout $
$(widgetFile "modifyUser")
Nothing -> do
setMessageI MsgUserUnknown
redirect HomeR
)
postModifyUserR :: UserId -> Handler Html
postModifyUserR uId = do
mUser <- runDB $ I.get uId
case mUser of
Just user -> do
postModifyUserR uId =
isUser uId HomeR >>= (\user -> do
rawbs <- runDB $ selectList [BarcodeUser ==. Just uId] []
let bs = map (barcodeCode . entityVal) rawbs
((res, _), _) <- runFormPost
@ -117,9 +111,7 @@ postModifyUserR uId = do
_ -> do
setMessageI MsgUserNotEdited
redirect $ SelectR uId
Nothing -> do
setMessageI MsgUserUnknown
redirect HomeR
)
modifyUserForm :: User -> [Text] -> AForm Handler UserConf
modifyUserForm user bs = UserConf

View file

@ -26,23 +26,17 @@ getRestockR = do
$(widgetFile "restock")
getUpstockR :: BeverageId -> Handler Html
getUpstockR bId = do
mBev <- runDB $ get bId
case mBev of
Just bev -> do
getUpstockR bId =
isBeverage bId RestockR >>= (\bev -> do
(upstockWidget, enctype) <- generateFormPost
$ renderBootstrap3 BootstrapBasicForm upstockForm
defaultLayout $
$(widgetFile "upstock")
Nothing -> do
setMessageI MsgItemUnknown
redirect RestockR
)
postUpstockR :: BeverageId -> Handler Html
postUpstockR bId = do
mBev <- runDB $ get bId
case mBev of
Just bev -> do
postUpstockR bId =
isBeverage bId RestockR >>= (\bev -> do
((res, _), _) <- runFormPost
$ renderBootstrap3 BootstrapBasicForm upstockForm
case res of
@ -60,9 +54,7 @@ postUpstockR bId = do
_ -> do
setMessageI MsgStockupError
redirect $ UpstockR bId
Nothing -> do
setMessageI MsgItemUnknown
redirect RestockR
)
data UpstockAmount = UpstockAmount
{ upstockSingles :: Int

View file

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

View file

@ -21,45 +21,29 @@ import Data.Maybe
import Text.Shakespeare.Text (stext)
getTransferSelectR :: UserId -> Handler Html
getTransferSelectR from = do
mUser <- runDB $ get from
case mUser of
Just _ -> do
getTransferSelectR from =
isUser from HomeR >>= (\_ -> do
users <- runDB $ selectList [UserId !=. from] [Asc UserIdent]
defaultLayout $
$(widgetFile "transferSelect")
Nothing -> do
setMessageI MsgUserUnknown
redirect HomeR
)
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
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")
Nothing -> do
setMessageI MsgUserUnknown
redirect $ TransferSelectR from
Nothing -> do
setMessageI MsgUserUnknown
redirect HomeR
)
)
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
postTransferR from to =
isUser from HomeR >>= (\sender ->
isUser to (TransferSelectR from) >>= (\recpt -> do
((res, _), _) <- runFormPost
$ renderBootstrap3 BootstrapBasicForm transferForm
case res of
@ -78,12 +62,8 @@ postTransferR from to = do
_ -> do
setMessageI MsgTransferError
redirect HomeR
Nothing -> do
setMessageI MsgUserUnknown
redirect $ TransferSelectR from
Nothing -> do
setMessageI MsgUserUnknown
redirect HomeR
)
)
transferForm :: AForm Handler Int
transferForm = areq currencyField (bfs MsgValue) (Just 0)