deduplication

Handler/Buy.hs

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

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

Handler/Modify.hs

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

Handler/NewUser.hs

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

Handler/Restock.hs

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

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
+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)

Handler/Transfer.hs

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