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