module Handler.AccountSettings where import Import import qualified ClassyPrelude.Yesod as CP getAccountSettingsR :: Handler Html getAccountSettingsR :: Handler Html getAccountSettingsR = do (UserId _, User user) <- forall master (m :: * -> *). (YesodAuthPersist master, Typeable (AuthEntity master), MonadHandler m, HandlerSite m ~ master) => m (AuthId master, AuthEntity master) requireAuthPair let accountSettingsEl :: Text accountSettingsEl = Text "accountSettings" :: Text let accountSettings :: AccountSettingsForm accountSettings = User -> AccountSettingsForm toAccountSettingsForm User user forall site. Yesod site => WidgetFor site () -> HandlerFor site Html defaultLayout do $(widgetFile "user-settings") forall site a (m :: * -> *). (ToWidgetBody site a, MonadWidget m, HandlerSite m ~ site) => a -> m () toWidgetBody [julius| app.userR = "@{UserR (UserNameP $ userName user)}"; app.dat.accountSettings = #{ toJSON accountSettings } || []; |] forall site a (m :: * -> *). (ToWidget site a, MonadWidget m, HandlerSite m ~ site) => a -> m () toWidget [julius| PS.renderAccountSettings('##{rawJS accountSettingsEl}')(app.dat.accountSettings)(); |] postEditAccountSettingsR :: Handler () postEditAccountSettingsR :: Handler () postEditAccountSettingsR = do UserId userId <- forall (m :: * -> *). (MonadHandler m, YesodAuth (HandlerSite m)) => m (AuthId (HandlerSite m)) requireAuthId AccountSettingsForm accountSettingsForm <- forall (m :: * -> *) a. (MonadHandler m, FromJSON a) => m a requireCheckJsonBody forall site a. YesodPersist site => YesodDB site a -> HandlerFor site a runDB (UserId -> AccountSettingsForm -> DB () updateUserFromAccountSettingsForm UserId userId AccountSettingsForm accountSettingsForm) getChangePasswordR :: Handler Html getChangePasswordR :: Handler Html getChangePasswordR = do forall (f :: * -> *) a. Functor f => f a -> f () void forall (m :: * -> *). (MonadHandler m, YesodAuth (HandlerSite m)) => m (AuthId (HandlerSite m)) requireAuthId YesodRequest req <- forall (m :: * -> *). MonadHandler m => m YesodRequest getRequest forall site. Yesod site => WidgetFor site () -> HandlerFor site Html defaultLayout forall a b. (a -> b) -> a -> b $ $(widgetFile "change-password") postChangePasswordR :: Handler Html postChangePasswordR :: Handler Html postChangePasswordR = do (UserId userId, User user) <- forall master (m :: * -> *). (YesodAuthPersist master, Typeable (AuthEntity master), MonadHandler m, HandlerSite m ~ master) => m (AuthId master, AuthEntity master) requireAuthPair forall (m :: * -> *) a. MonadHandler m => FormInput m a -> m (FormResult a) runInputPostResult ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *) a. (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m a -> Text -> FormInput m a ireq forall (m :: * -> *). (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m Text textField Text "oldpassword" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall (m :: * -> *) a. (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m a -> Text -> FormInput m a ireq forall (m :: * -> *). (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m Text textField Text "newpassword") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case FormSuccess (Text old, Text new) -> do forall site a. YesodPersist site => YesodDB site a -> HandlerFor site a runDB (Text -> Text -> DB (Maybe (Entity User)) authenticatePassword (User -> Text userName User user) Text old) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case Maybe (Entity User) Nothing -> forall (m :: * -> *). MonadHandler m => Html -> m () setMessage Html "Incorrect Old Password" Just Entity User _ -> Text -> Handler (Maybe Text) validateNewPassword Text new forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case Just Text newValid -> do BCrypt newHash <- forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (Text -> IO BCrypt hashPassword Text newValid) forall (f :: * -> *) a. Functor f => f a -> f () void forall a b. (a -> b) -> a -> b $ forall site a. YesodPersist site => YesodDB site a -> HandlerFor site a runDB (forall backend record (m :: * -> *). (PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend) => Key record -> [Update record] -> ReaderT backend m () update UserId userId [forall typ. (typ ~ BCrypt) => EntityField User typ UserPasswordHash forall v typ. PersistField typ => EntityField v typ -> typ -> Update v CP.=. BCrypt newHash]) forall (m :: * -> *). MonadHandler m => Html -> m () setMessage Html "Password Changed Successfully" Maybe Text _ -> forall (f :: * -> *) a. Applicative f => a -> f a pure () FormResult (Text, Text) _ -> forall (m :: * -> *). MonadHandler m => Html -> m () setMessage Html "Missing Required Fields" forall (m :: * -> *) url a. (MonadHandler m, RedirectUrl (HandlerSite m) url) => url -> m a redirect Route App ChangePasswordR validateNewPassword :: Text -> Handler (Maybe Text) validateNewPassword :: Text -> Handler (Maybe Text) validateNewPassword = \case Text new | forall mono. MonoFoldable mono => mono -> Int length Text new forall a. Ord a => a -> a -> Bool < Int 6 -> do forall (m :: * -> *). MonadHandler m => Html -> m () setMessage Html "Password must be at least 6 characters long" forall (f :: * -> *) a. Applicative f => a -> f a pure forall a. Maybe a Nothing Text new -> forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall a. a -> Maybe a Just Text new