extend pin protection

Handler/Buy.hs

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

Handler/Pinentry.hs

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

Handler/Select.hs

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