extend pin protection

This commit is contained in:
nek0 2018-10-02 20:51:56 +02:00
parent 438844d340
commit 5f4f7678c5
3 changed files with 74 additions and 47 deletions

View file

@ -19,54 +19,83 @@ import Import
import Handler.Common import Handler.Common
import Text.Shakespeare.Text import Text.Shakespeare.Text
import qualified Data.Text as T (pack)
getBuyR :: UserId -> BeverageId -> Handler Html getBuyR :: UserId -> BeverageId -> Handler Html
getBuyR uId bId = do getBuyR uId bId = do
(user, bev) <- checkData uId bId mpin <- lookupSession "pinentry"
master <- getYesod case mpin of
(buyWidget, enctype) <- generateFormPost Just ppin ->
$ renderBootstrap3 BootstrapBasicForm if ppin == T.pack (show uId)
$ buyForm then do
defaultLayout $ do (user, bev) <- checkData uId bId
setTitleI (MsgPurchaseOf (beverageIdent bev)) master <- getYesod
$(widgetFile "buy") (buyWidget, enctype) <- generateFormPost
$ renderBootstrap3 BootstrapBasicForm
$ buyForm
defaultLayout $ do
setTitleI (MsgPurchaseOf (beverageIdent bev))
$(widgetFile "buy")
else do
deleteSession "pinentry"
setMessageI MsgWrongPin
redirect HomeR
Nothing -> do
setMessageI MsgWrongPin
redirect HomeR
postBuyR :: UserId -> BeverageId -> Handler Html postBuyR :: UserId -> BeverageId -> Handler Html
postBuyR uId bId = do postBuyR uId bId = do
(user, bev) <- checkData uId bId mpin <- lookupSession "pinentry"
((res, _), _) <- runFormPost case mpin of
$ renderBootstrap3 BootstrapBasicForm Just ppin ->
$ buyForm if ppin == T.pack (show uId)
case res of then do
FormSuccess quant -> do (user, bev) <- checkData uId bId
if quant > beverageAmount bev ((res, _), _) <- runFormPost
then do $ renderBootstrap3 BootstrapBasicForm
setMessageI MsgNotEnoughItems $ buyForm
redirect $ BuyR uId bId case res of
else do FormSuccess quant -> do
let price = quant * (beveragePrice bev) if quant > beverageAmount bev
let sw = price > (userBalance user) then do
today <- liftIO $ return . utctDay =<< getCurrentTime setMessageI MsgNotEnoughItems
runDB $ do redirect $ BuyR uId bId
update uId [UserTimestamp =. today] else do
update uId [UserBalance -=. price] let price = quant * (beveragePrice bev)
update bId [BeverageAmount -=. quant] let sw = price > (userBalance user)
update bId [BeverageTotalBought +=. 1] today <- liftIO $ return . utctDay =<< getCurrentTime
checkAlert bId (beverageAmount bev) runDB $ do
master <- getYesod update uId [UserTimestamp =. today]
liftIO $ notifyUser user bev quant price master update uId [UserBalance -=. price]
case sw of update bId [BeverageAmount -=. quant]
False -> do update bId [BeverageTotalBought +=. 1]
setMessageI MsgPurchaseSuccess checkAlert bId (beverageAmount bev)
redirect HomeR master <- getYesod
True -> do liftIO $ notifyUser user bev quant price master
let level = case userBalance user - price of case sw of
balance False -> do
| balance <= -5000 -> 3 deleteSession "pinentry"
| balance <= -1000 -> 2 setMessageI MsgPurchaseSuccess
| otherwise -> 1 redirect HomeR
redirect $ DemandR level True -> do
_ -> do deleteSession "pinentry"
setMessageI MsgErrorOccured let level = case userBalance user - price of
balance
| balance <= -5000 -> 3
| balance <= -1000 -> 2
| otherwise -> 1
redirect $ DemandR level
_ -> do
deleteSession "pinentry"
setMessageI MsgErrorOccured
redirect HomeR
else do
deleteSession "pinentry"
setMessageI MsgWrongPin
redirect HomeR
Nothing -> do
setMessageI MsgWrongPin
redirect HomeR redirect HomeR
notifyUser :: User -> Beverage -> Int -> Int -> App -> IO () notifyUser :: User -> Beverage -> Int -> Int -> App -> IO ()

View file

@ -1,4 +1,3 @@
{-# LANGUAGE DoAndIfThenElse #-}
module Handler.Pinentry where module Handler.Pinentry where
import Import import Import
@ -35,7 +34,7 @@ postPinentryR uId = do
$ renderBootstrap3 BootstrapBasicForm $ renderBootstrap3 BootstrapBasicForm
$ pinentryForm $ pinentryForm
case res of case res of
FormSuccess ppin -> do FormSuccess ppin ->
if ppin == pin if ppin == pin
then do then do
setSession "pinentry" (T.pack $ show uId) setSession "pinentry" (T.pack $ show uId)

View file

@ -28,10 +28,9 @@ getSelectR uId =
mpin <- lookupSession "pinentry" mpin <- lookupSession "pinentry"
case mpin of case mpin of
Nothing -> redirect $ PinentryR uId Nothing -> redirect $ PinentryR uId
Just ppin -> do Just ppin ->
if ppin == T.pack (show uId) if ppin == T.pack (show uId)
then do then do
deleteSession "pinentry"
beverages <- runDB $ selectList [BeverageAmount >. 0] [Asc BeverageIdent] beverages <- runDB $ selectList [BeverageAmount >. 0] [Asc BeverageIdent]
defaultLayout $ do defaultLayout $ do
addScript $ StaticR js_barcode_js addScript $ StaticR js_barcode_js