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| + +
confirm new password: + + |] + , fieldEnctype = UrlEncoded + } + +updatePassword :: Key User -> Maybe Text -> Handler () +updatePassword _ Nothing = return () +updatePassword userId (Just password) = do + encodedPassword <- liftIO $ makePassword (encodeUtf8 password) defaultStrength + runDB $ update userId [UserPassword =. Just (decodeUtf8 encodedPassword)] + setMessage $ toHtml ("Password set!" :: Text) diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index 7110388..b58093c 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -13,7 +13,6 @@ import System.Directory (doesFileExist) import qualified Data.Text as T import qualified Yesod.Table as Table -import Yesod.Table (Table) import Handler.Extract import Handler.Shared @@ -22,7 +21,6 @@ import Handler.Tables import GEval.Core import GEval.OptionsParser -import Data.Map (Map) import qualified Data.Map as Map import PersistSHA1 diff --git a/Handler/YourAccount.hs b/Handler/YourAccount.hs index 9807e8f..ad454e4 100644 --- a/Handler/YourAccount.hs +++ b/Handler/YourAccount.hs @@ -8,8 +8,8 @@ import Text.Regex.TDFA import Data.Conduit.Binary import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L -import Crypto.PasswordStore -import Yesod.Auth.HashDB (defaultStrength) + +import Handler.Common (passwordConfirmField, updatePassword) getYourAccountR :: Handler Html getYourAccountR = do @@ -69,13 +69,6 @@ updateUserAccount userId name maybeLocalId maybePassword maybeSshPubKey maybeAva updateLocalIdAndPubKey userId maybeLocalId maybeSshPubKey updatePassword userId maybePassword -updatePassword :: Key User -> Maybe Text -> Handler () -updatePassword _ Nothing = return () -updatePassword userId (Just password) = do - encodedPassword <- liftIO $ makePassword (encodeUtf8 password) defaultStrength - runDB $ update userId [UserPassword =. Just (decodeUtf8 encodedPassword)] - setMessage $ toHtml ("Password set!" :: Text) - updateAvatar :: Key User -> Maybe FileInfo -> Handler () updateAvatar _ Nothing = return () updateAvatar userId (Just avatarFile) = do @@ -129,21 +122,3 @@ getAvatarR userId = do sendResponse (typePng, toContent avatarBytes) Nothing -> do sendFile typeSvg "static/images/male-avatar.svg" - -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| - -
confirm new password: - - |] - , fieldEnctype = UrlEncoded - } diff --git a/config/models b/config/models index 4f0addc..3a34f2a 100644 --- a/config/models +++ b/config/models @@ -7,6 +7,8 @@ User localId Text Maybe isAnonymous Bool default=False avatar ByteString Maybe + verificationKey Text Maybe + keyExpirationDate UTCTime Maybe deriving Typeable PublicKey user UserId diff --git a/config/routes b/config/routes index 9667696..5bce25d 100644 --- a/config/routes +++ b/config/routes @@ -28,5 +28,7 @@ /account YourAccountR GET POST /avatar/#UserId AvatarR GET +/create-reset-link CreateResetLinkR GET POST +/reset-password/#Text ResetPasswordR GET POST /presentation/4real Presentation4RealR GET diff --git a/gonito.cabal b/gonito.cabal index 9b471cd..0996d0d 100644 --- a/gonito.cabal +++ b/gonito.cabal @@ -43,6 +43,7 @@ library Handler.Query Handler.Tables Handler.YourAccount + Handler.AccountReset Handler.Presentation if flag(dev) || flag(library-only) @@ -129,6 +130,7 @@ library , yesod-newsfeed , yesod-auth-hashdb , pwstore-fast + , nonce executable gonito if flag(library-only) diff --git a/messages/en.msg b/messages/en.msg index 2b5ff16..f3fe06b 100644 --- a/messages/en.msg +++ b/messages/en.msg @@ -26,3 +26,6 @@ Send: Send Avatar: avatar About: about Password: new password +EMail: e-mail +CreateResetLink: create reset link +LinkWrongOrExpired: Link wrong or expired, please ask the site admin again diff --git a/templates/create-reset-link.hamlet b/templates/create-reset-link.hamlet new file mode 100644 index 0000000..b9e79f3 --- /dev/null +++ b/templates/create-reset-link.hamlet @@ -0,0 +1,6 @@ +

Create a link for account creation or password reset + +
+ ^{formWidget} +