adding PIN "protection"

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

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

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|
+            <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)

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 <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

config/models

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

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

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

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