diff --git a/Application.hs b/Application.hs index 8b66688..05370c9 100644 --- a/Application.hs +++ b/Application.hs @@ -47,6 +47,7 @@ import Handler.Query import Handler.ShowChallenge import Handler.Shared import Handler.YourAccount +import Handler.AccountReset import Handler.Presentation -- This line actually creates our YesodDispatch instance. It is the second half diff --git a/Foundation.hs b/Foundation.hs index 752cc76..bce5a3f 100644 --- a/Foundation.hs +++ b/Foundation.hs @@ -58,6 +58,13 @@ isTrustedAuthorized = do | isTrusted user -> return Authorized | otherwise -> return $ Unauthorized "???" +isAdmin = do + mauth <- maybeAuth + case mauth of + Nothing -> return AuthenticationRequired + Just (Entity _ user) + | userIsAdmin user -> return Authorized + | otherwise -> return $ Unauthorized "only permitted for the admin" isTrusted :: User -> Bool isTrusted user = @@ -124,6 +131,9 @@ instance Yesod App where isAuthorized (AvatarR _) _ = return Authorized + isAuthorized CreateResetLinkR _ = isAdmin + isAuthorized (ResetPasswordR _) _ = return Authorized + -- Default to Authorized for now. isAuthorized _ _ = isTrustedAuthorized @@ -196,6 +206,8 @@ instance YesodAuth App where , userLocalId = Nothing , userIsAnonymous = False , userAvatar = Nothing + , userVerificationKey = Nothing + , userKeyExpirationDate = Nothing } -- You can add other plugins like BrowserID, email or OAuth here diff --git a/Handler/AccountReset.hs b/Handler/AccountReset.hs new file mode 100644 index 0000000..1cd3f31 --- /dev/null +++ b/Handler/AccountReset.hs @@ -0,0 +1,118 @@ +module Handler.AccountReset where + +import Import +import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs) + +import qualified Crypto.Nonce as Nonce +import System.IO.Unsafe (unsafePerformIO) + +import Data.Time.Clock (addUTCTime) + +import Handler.Common (passwordConfirmField, updatePassword) + +getCreateResetLinkR :: Handler Html +getCreateResetLinkR = do + (formWidget, formEnctype) <- generateFormPost createResetLinkForm + defaultLayout $ do + setTitle "Create a reset link" + $(widgetFile "create-reset-link") + +postCreateResetLinkR :: Handler Html +postCreateResetLinkR = do + ((result, _), _) <- runFormPost createResetLinkForm + let mEmail = case result of + FormSuccess email -> Just email + _ -> Nothing + doCreateResetLink mEmail + +doCreateResetLink :: Maybe Text -> Handler Html +doCreateResetLink (Just email) = do + mUserEnt <- runDB $ getBy $ UniqueUser email + userId <- createOrUse mUserEnt email + + key <- newVerifyKey + theNow <- liftIO getCurrentTime + let expirationMoment = addUTCTime (60*60*24) theNow + runDB $ update userId [UserVerificationKey =. Just key, UserKeyExpirationDate =. Just expirationMoment] + + defaultLayout $ do + setTitle "Creating a reset link" + $(widgetFile "reset-link-created") + +doCreateResetLink Nothing = do + setMessage $ toHtml ("No e-mail given" :: Text) + getCreateResetLinkR + +createOrUse :: Maybe (Entity User) -> Text -> Handler UserId +createOrUse (Just userEnt) _ = return $ entityKey userEnt +createOrUse Nothing email = do + setMessage $ toHtml ("Created new user " ++ email) + userId <- runDB $ insert $ User email Nothing Nothing False Nothing True Nothing Nothing Nothing + return userId + +createResetLinkForm :: Form Text +createResetLinkForm = renderBootstrap3 BootstrapBasicForm + $ areq textField (bfs MsgEMail) Nothing + + +nonceGen :: Nonce.Generator +nonceGen = unsafePerformIO Nonce.new +{-# NOINLINE nonceGen #-} + +-- | Randomly create a new verification key. +newVerifyKey :: MonadIO m => m Text +newVerifyKey = Nonce.nonce128urlT nonceGen + + +getResetPasswordR :: Text -> Handler Html +getResetPasswordR key = do + (formWidget, formEnctype) <- generateFormPost changePasswordForm + mUserId <- checkVerificationKey key + master <- getYesod + defaultLayout $ do + setTitle "Reset password" + $(widgetFile "reset-password") + +postResetPasswordR :: Text -> Handler Html +postResetPasswordR key = do + ((result, _), _) <- runFormPost changePasswordForm + mUserId <- checkVerificationKey key + let mPassword = case result of + FormSuccess password -> Just password + _ -> Nothing + doResetPassword key mUserId mPassword + +doResetPassword :: Text -> Maybe (Key User) -> Maybe Text -> Handler Html +doResetPassword key _ Nothing = do + setMessage $ toHtml ("Password not given or does not match! Make sure you entered the same password" :: Text) + getResetPasswordR key + +doResetPassword _ (Just userId) (Just password) = do + updatePassword userId (Just password) + runDB $ update userId removeVerificationKeyStatement + defaultLayout $ do + setTitle "Reset password" + $(widgetFile "password-reset") + +doResetPassword key Nothing _ = do + runDB $ updateWhere [UserVerificationKey ==. Just key] removeVerificationKeyStatement + master <- getYesod + defaultLayout $ do + setTitle "Reset password" + $(widgetFile "password-reset-failed") + +removeVerificationKeyStatement :: [Update User] +removeVerificationKeyStatement = [UserVerificationKey =. Nothing, UserKeyExpirationDate =. Nothing] + + +checkVerificationKey :: Text -> Handler (Maybe UserId) +checkVerificationKey key = do + theNow <- liftIO getCurrentTime + userEnts <- runDB $ selectList [UserVerificationKey ==. Just key, UserKeyExpirationDate >. Just theNow] [] + return $ case userEnts of + [Entity k _] -> Just k + _ -> Nothing + +changePasswordForm :: Form Text +changePasswordForm = renderBootstrap3 BootstrapBasicForm + $ areq passwordConfirmField (bfs MsgPassword) Nothing diff --git a/Handler/Common.hs b/Handler/Common.hs index eadd206..f76f3b9 100644 --- a/Handler/Common.hs +++ b/Handler/Common.hs @@ -4,6 +4,10 @@ module Handler.Common where import Data.FileEmbed (embedFile) import Import +import Crypto.PasswordStore +import Yesod.Auth.HashDB (defaultStrength) + + -- These handlers embed files in the executable at compile time to avoid a -- runtime dependency, and for efficiency. @@ -14,3 +18,29 @@ getFaviconR = return $ TypedContent "image/x-icon" getRobotsR :: Handler TypedContent getRobotsR = return $ TypedContent typePlain $ toContent $(embedFile "config/robots.txt") + + +passwordConfirmField :: Field Handler Text +passwordConfirmField = Field + { fieldParse = \rawVals _fileVals -> + case rawVals of + [a, b] + | a == b -> return $ Right $ Just a + | otherwise -> return $ Left "Passwords don't match" + [] -> return $ Right Nothing + _ -> return $ Left "You must enter two values" + , fieldView = \idAttr nameAttr otherAttrs _ _ -> + [whamlet| + +