adding PIN "protection"

This commit is contained in:
nek0 2018-10-02 20:25:32 +02:00
parent 1a2e12010c
commit 438844d340
8 changed files with 89 additions and 5 deletions

View File

@ -57,6 +57,7 @@ import Handler.Supplier
import Handler.SupplierActions
import Handler.Demand
import Handler.Statistics
import Handler.Pinentry
-- This line actually creates our YesodDispatch instance. It is the second half
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the

View File

@ -70,6 +70,7 @@ newUserForm today = User
<*> pure today
<*> aopt emailField (bfs MsgEmailNotify) Nothing
<*> aopt (selectField avatars) (bfs MsgSelectAvatar) Nothing
<*> aopt passwordField (bfs MsgUserPin) Nothing
<* bootstrapSubmit (msgToBSSubmit MsgSubmit)
where
avatars = do
@ -81,6 +82,7 @@ data UserConf = UserConf
, userConfEmail :: Maybe Text
, userConfAvatar :: Maybe AvatarId
, userConfBarcode :: Maybe [Text]
, userConfPIN :: Maybe Text
}
getModifyUserR :: UserId -> Handler Html
@ -115,6 +117,7 @@ postModifyUserR uId =
[ UserIdent =. userConfIdent uc
, UserEmail =. userConfEmail uc
, UserAvatar =. userConfAvatar uc
, UserPin =. userConfPIN uc
]
liftIO $ notify user (userConfEmail uc)
handleBarcodes (Left uId) (fromMaybe [] $ userConfBarcode uc)
@ -134,6 +137,7 @@ modifyUserForm user bs = UserConf
<*> aopt emailField (bfs MsgEmailNotify) (Just $ userEmail user)
<*> aopt (selectField avatars) (bfs MsgSelectAvatar) (Just $ userAvatar user)
<*> aopt barcodeField (bfs MsgBarcodeField) (Just $ Just bs)
<*> aopt passwordField (bfs MsgUserPin) Nothing
<* bootstrapSubmit (msgToBSSubmit MsgSubmit)
where
avatars = do

58
Handler/Pinentry.hs Normal file
View File

@ -0,0 +1,58 @@
{-# LANGUAGE DoAndIfThenElse #-}
module Handler.Pinentry where
import Import
import Handler.Common
import qualified Data.Text as T (pack)
getPinentryR :: UserId -> Handler Html
getPinentryR uId =
isUser uId HomeR >>= (\user -> do
case userPin user of
Just pin -> do
(pinWidget, enctype) <- generateFormPost
$ renderBootstrap3 BootstrapBasicForm
$ pinentryForm
defaultLayout $ do
[whamlet|
<h3>_{MsgEnterPin}
<form method="post" enctype=#{enctype}>
^{pinWidget}
|]
Nothing -> do
setSession "pinentry" (T.pack $ show uId)
redirect $ SelectR uId
)
postPinentryR :: UserId -> Handler Html
postPinentryR uId = do
isUser uId HomeR >>= (\user -> do
case userPin user of
Just pin -> do
((res, _), _) <- runFormPost
$ renderBootstrap3 BootstrapBasicForm
$ pinentryForm
case res of
FormSuccess ppin -> do
if ppin == pin
then do
setSession "pinentry" (T.pack $ show uId)
redirect $ SelectR uId
else do
deleteSession "pinentry"
setMessageI MsgWrongPin
redirect HomeR
_ -> do
deleteSession "pinentry"
setMessageI MsgPinFailure
redirect HomeR
Nothing -> do
setSession "pinentry" (T.pack $ show uId)
redirect $ SelectR uId
)
pinentryForm :: AForm Handler Text
pinentryForm = areq passwordField (bfs MsgPIN) Nothing
<* bootstrapSubmit (msgToBSSubmit MsgSubmit)

View File

@ -13,6 +13,7 @@
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE DoAndIfThenElse #-}
module Handler.Select where
import Import
@ -24,11 +25,22 @@ getSelectR :: UserId -> Handler Html
getSelectR uId =
isUser uId HomeR >>= (\user -> do
master <- getYesod
beverages <- runDB $ selectList [BeverageAmount >. 0] [Asc BeverageIdent]
defaultLayout $ do
addScript $ StaticR js_barcode_js
setTitleI MsgSelectItem
$(widgetFile "select")
mpin <- lookupSession "pinentry"
case mpin of
Nothing -> redirect $ PinentryR uId
Just ppin -> do
if ppin == T.pack (show uId)
then do
deleteSession "pinentry"
beverages <- runDB $ selectList [BeverageAmount >. 0] [Asc BeverageIdent]
defaultLayout $ do
addScript $ StaticR js_barcode_js
setTitleI MsgSelectItem
$(widgetFile "select")
else do
deleteSession "pinentry"
setMessageI MsgWrongPinAuth
redirect HomeR
)
getSelectCashR :: Handler Html

View File

@ -4,6 +4,7 @@ User
timestamp Day
email Text Maybe
avatar AvatarId Maybe
pin Text Maybe
UniqueUser ident
deriving Typeable Show

View File

@ -45,5 +45,6 @@
/supply/#SupplierId/digest SupplierDigestR GET
/supply/#SupplierId/delete DeleteSupplierR GET
/demand/#Int DemandR GET
/pin/#UserId PinentryR GET POST
/statistics.json StatisticsR GET

View File

@ -151,3 +151,9 @@ MainPage: Hauptseite
ModifyBeverage ident@Text: Artikel #{ident} bearbeiten
ModifyUser ident@Text: Benutzer #{ident} bearbeiten
SupplierActions ident@Text: Aktionen für Lieferant #{ident}
UserPin: Benutzer-PIN
WrongPinAuth: Falsche Pin fpr diesen Benutzer
EnterPin: Bitte PIN Eingeben
WrongPin: Falsche PIN eingegeben
PinFailure: Fehler bei der Pineingabe
PIN: PIN

View File

@ -41,6 +41,7 @@ library
Handler.SupplierActions
Handler.Demand
Handler.Statistics
Handler.Pinentry
if flag(dev) || flag(library-only)
cpp-options: -DDEVELOPMENT -DHTTP_CLIENT