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 Text.Shakespeare.Text
import qualified Data.Text as T (pack)
getBuyR :: UserId -> BeverageId -> Handler Html
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
master <- getYesod
(buyWidget, enctype) <- generateFormPost
@ -29,9 +36,21 @@ getBuyR uId bId = do
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 uId bId = do
mpin <- lookupSession "pinentry"
case mpin of
Just ppin ->
if ppin == T.pack (show uId)
then do
(user, bev) <- checkData uId bId
((res, _), _) <- runFormPost
$ renderBootstrap3 BootstrapBasicForm
@ -56,9 +75,11 @@ postBuyR uId bId = do
liftIO $ notifyUser user bev quant price master
case sw of
False -> do
deleteSession "pinentry"
setMessageI MsgPurchaseSuccess
redirect HomeR
True -> do
deleteSession "pinentry"
let level = case userBalance user - price of
balance
| balance <= -5000 -> 3
@ -66,8 +87,16 @@ postBuyR uId bId = do
| 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
notifyUser :: User -> Beverage -> Int -> Int -> App -> IO ()
notifyUser user bev quant price master = do

View file

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

View file

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