adjust password validation

src/Handler/AccountSettings.hs

@@ -34,17 +34,23 @@ getChangePasswordR = do
 
 postChangePasswordR :: Handler Html
 postChangePasswordR = do
-  userId <- requireAuthId
+  (userId, user) <- requireAuthPair
-  mauthuname <- maybeAuthUsername
+  runInputPostResult ((,) <$> ireq textField "oldpassword" <*> ireq textField "newpassword") >>= \case
-  mresult <- runInputPostResult ((,) <$> ireq textField "oldpassword" <*> ireq textField "newpassword")
+    FormSuccess (old, new) -> do
-  case (mauthuname, mresult) of
+      runDB (authenticatePassword (userName user) old) >>= \case
-    (Just uname, FormSuccess (old, new)) -> do
+        Nothing -> setMessage "Incorrect Old Password"
-      muser <- runDB (authenticatePassword uname old)
+        Just _ -> validateNewPassword new >>= \case
-      case muser of
+          Just newValid -> do
-        Just _ -> do 
+            newHash <- liftIO (hashPassword newValid)
-          new' <- liftIO (hashPassword new)
+            void $ runDB (update userId [UserPasswordHash CP.=. newHash])
-          void $ runDB (update userId [UserPasswordHash CP.=. new'])
+            setMessage "Password Changed Successfully"
-          setMessage "Password Changed Successfully"
+          _ -> pure ()
-        _ -> setMessage "Incorrect Old Password"
     _ -> setMessage "Missing Required Fields"
   redirect ChangePasswordR
+
+validateNewPassword :: Text -> Handler (Maybe Text)
+validateNewPassword = \case
+    new | length new < 6 -> do
+          setMessage "Password must be at least 6 characters long"
+          pure Nothing
+    new -> pure $ Just new

src/Model.hs

@@ -148,13 +148,12 @@ sqliteGroupConcat expr sep = unsafeSqlFunction "GROUP_CONCAT" [expr, sep]
 
 authenticatePassword :: Text -> Text -> DB (Maybe (Entity User))
 authenticatePassword username password = do
-  muser <- getBy (UniqueUserName username)
+  getBy (UniqueUserName username) >>= \case
-  case muser of
+    Nothing -> pure Nothing
-    Nothing -> return Nothing
     Just dbuser ->
       if validatePasswordHash (userPasswordHash (entityVal dbuser)) password
-        then return (Just dbuser)
+        then pure (Just dbuser)
-        else return Nothing
+        else pure Nothing
 
 getUserByName :: UserNameP -> DB (Maybe (Entity User))
 getUserByName (UserNameP uname) =