From 438844d34098eb8aa9804257206e58699538dd8a Mon Sep 17 00:00:00 2001 From: nek0 Date: Tue, 2 Oct 2018 20:25:32 +0200 Subject: [PATCH] adding PIN "protection" --- Application.hs | 1 + Handler/NewUser.hs | 4 ++++ Handler/Pinentry.hs | 58 +++++++++++++++++++++++++++++++++++++++++++++ Handler/Select.hs | 22 +++++++++++++---- config/models | 1 + config/routes | 1 + messages/de.msg | 6 +++++ yammat.cabal | 1 + 8 files changed, 89 insertions(+), 5 deletions(-) create mode 100644 Handler/Pinentry.hs diff --git a/Application.hs b/Application.hs index 716c7df..9ebdb48 100644 --- a/Application.hs +++ b/Application.hs @@ -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 diff --git a/Handler/NewUser.hs b/Handler/NewUser.hs index a71bab6..db1d8f1 100644 --- a/Handler/NewUser.hs +++ b/Handler/NewUser.hs @@ -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 diff --git a/Handler/Pinentry.hs b/Handler/Pinentry.hs new file mode 100644 index 0000000..0aa6ffb --- /dev/null +++ b/Handler/Pinentry.hs @@ -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| +

_{MsgEnterPin} +
+ ^{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) diff --git a/Handler/Select.hs b/Handler/Select.hs index 75ba867..82bb26f 100644 --- a/Handler/Select.hs +++ b/Handler/Select.hs @@ -13,6 +13,7 @@ -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . +{-# 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 diff --git a/config/models b/config/models index 3655cb0..510c0d1 100644 --- a/config/models +++ b/config/models @@ -4,6 +4,7 @@ User timestamp Day email Text Maybe avatar AvatarId Maybe + pin Text Maybe UniqueUser ident deriving Typeable Show diff --git a/config/routes b/config/routes index b899cf4..5a03f33 100644 --- a/config/routes +++ b/config/routes @@ -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 diff --git a/messages/de.msg b/messages/de.msg index be05f35..1db677b 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -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 diff --git a/yammat.cabal b/yammat.cabal index e08bf1d..c01c316 100644 --- a/yammat.cabal +++ b/yammat.cabal @@ -41,6 +41,7 @@ library Handler.SupplierActions Handler.Demand Handler.Statistics + Handler.Pinentry if flag(dev) || flag(library-only) cpp-options: -DDEVELOPMENT -DHTTP_CLIENT