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,8 +19,15 @@ 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
mpin <- lookupSession "pinentry"
case mpin of
Just ppin ->
if ppin == T.pack (show uId)
then do
(user, bev) <- checkData uId bId (user, bev) <- checkData uId bId
master <- getYesod master <- getYesod
(buyWidget, enctype) <- generateFormPost (buyWidget, enctype) <- generateFormPost
@ -29,9 +36,21 @@ getBuyR uId bId = do
defaultLayout $ do defaultLayout $ do
setTitleI (MsgPurchaseOf (beverageIdent bev)) setTitleI (MsgPurchaseOf (beverageIdent bev))
$(widgetFile "buy") $(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
mpin <- lookupSession "pinentry"
case mpin of
Just ppin ->
if ppin == T.pack (show uId)
then do
(user, bev) <- checkData uId bId (user, bev) <- checkData uId bId
((res, _), _) <- runFormPost ((res, _), _) <- runFormPost
$ renderBootstrap3 BootstrapBasicForm $ renderBootstrap3 BootstrapBasicForm
@ -56,9 +75,11 @@ postBuyR uId bId = do
liftIO $ notifyUser user bev quant price master liftIO $ notifyUser user bev quant price master
case sw of case sw of
False -> do False -> do
deleteSession "pinentry"
setMessageI MsgPurchaseSuccess setMessageI MsgPurchaseSuccess
redirect HomeR redirect HomeR
True -> do True -> do
deleteSession "pinentry"
let level = case userBalance user - price of let level = case userBalance user - price of
balance balance
| balance <= -5000 -> 3 | balance <= -5000 -> 3
@ -66,8 +87,16 @@ postBuyR uId bId = do
| otherwise -> 1 | otherwise -> 1
redirect $ DemandR level redirect $ DemandR level
_ -> do _ -> do
deleteSession "pinentry"
setMessageI MsgErrorOccured setMessageI MsgErrorOccured
redirect HomeR redirect HomeR
else do
deleteSession "pinentry"
setMessageI MsgWrongPin
redirect HomeR
Nothing -> do
setMessageI MsgWrongPin
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

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