diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index 75bb3d47..5b383cc3 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -1,6 +1,7 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternGuards #-} module Yesod.Auth.Email ( -- * Plugin authEmail @@ -10,31 +11,40 @@ module Yesod.Auth.Email -- * Routes , loginR , registerR + , forgotPasswordR , setpassR , isValidPass + -- * Types + , Email + , VerKey + , VerUrl + , SaltedPass + , VerStatus + , Identifier ) where import Network.Mail.Mime (randomString) import Yesod.Auth import System.Random -import Control.Monad (when) -import Control.Applicative ((<$>), (<*>)) import Data.Digest.Pure.MD5 -import qualified Data.Text.Lazy as T import qualified Data.Text as TS -import Data.Text.Lazy.Encoding (encodeUtf8) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TLE +import Data.Text.Encoding (encodeUtf8, decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) import Data.Text (Text) -import qualified Crypto.PasswordStore as PS -import qualified Data.Text.Encoding as DTE -import Control.Monad.Trans.Class - -import Yesod.Form import Yesod.Core +import qualified Crypto.PasswordStore as PS +import qualified Text.Email.Validate import qualified Yesod.Auth.Message as Msg +import Control.Applicative ((<$>), (<*>)) +import Yesod.Form +import Control.Monad (when) -loginR, registerR, setpassR :: AuthRoute +loginR, registerR, forgotPasswordR, setpassR :: AuthRoute loginR = PluginR "email" ["login"] registerR = PluginR "email" ["register"] +forgotPasswordR = PluginR "email" ["forgot-password"] setpassR = PluginR "email" ["set-password"] verify :: Text -> Text -> AuthRoute -- FIXME @@ -46,33 +56,86 @@ type VerUrl = Text type SaltedPass = Text type VerStatus = Bool +-- | An Identifier generalizes an email address to allow users to log in with +-- some other form of credentials (e.g., username). +-- +-- Note that any of these other identifiers must not be valid email addresses. +-- +-- Since 1.2.0 +type Identifier = Text + -- | Data stored in a database for each e-mail address. -data EmailCreds m = EmailCreds - { emailCredsId :: AuthEmailId m - , emailCredsAuthId :: Maybe (AuthId m) +data EmailCreds site = EmailCreds + { emailCredsId :: AuthEmailId site + , emailCredsAuthId :: Maybe (AuthId site) , emailCredsStatus :: VerStatus , emailCredsVerkey :: Maybe VerKey + , emailCredsEmail :: Email } class (YesodAuth site, PathPiece (AuthEmailId site)) => YesodAuthEmail site where type AuthEmailId site + -- | Add a new email address to the database, but indicate that the address + -- has not yet been verified. + -- + -- Since 1.1.0 addUnverified :: Email -> VerKey -> HandlerT site IO (AuthEmailId site) + + -- | Send an email to the given address to verify ownership. + -- + -- Since 1.1.0 sendVerifyEmail :: Email -> VerKey -> VerUrl -> HandlerT site IO () + + -- | Get the verification key for the given email ID. + -- + -- Since 1.1.0 getVerifyKey :: AuthEmailId site -> HandlerT site IO (Maybe VerKey) + + -- | Set the verification key for the given email ID. + -- + -- Since 1.1.0 setVerifyKey :: AuthEmailId site -> VerKey -> HandlerT site IO () + + -- | Verify the email address on the given account. + -- + -- Since 1.1.0 verifyAccount :: AuthEmailId site -> HandlerT site IO (Maybe (AuthId site)) + + -- | Get the salted password for the given account. + -- + -- Since 1.1.0 getPassword :: AuthId site -> HandlerT site IO (Maybe SaltedPass) + + -- | Set the salted password for the given account. + -- + -- Since 1.1.0 setPassword :: AuthId site -> SaltedPass -> HandlerT site IO () - getEmailCreds :: Email -> HandlerT site IO (Maybe (EmailCreds site)) + + -- | Get the credentials for the given @Identifier@, which may be either an + -- email address or some other identification (e.g., username). + -- + -- Since 1.2.0 + getEmailCreds :: Identifier -> HandlerT site IO (Maybe (EmailCreds site)) + + -- | Get the email address for the given email ID. + -- + -- Since 1.1.0 getEmail :: AuthEmailId site -> HandlerT site IO (Maybe Email) -- | Generate a random alphanumeric string. + -- + -- Since 1.1.0 randomKey :: site -> IO Text randomKey _ = do stdgen <- newStdGen return $ TS.pack $ fst $ randomString 10 stdgen + -- | Route to send user to after password has been set correctly. + -- + -- Since 1.2.0 + afterPasswordRoute :: site -> Route site + authEmail :: YesodAuthEmail m => AuthPlugin m authEmail = AuthPlugin "email" dispatch $ \tm -> @@ -96,6 +159,8 @@ $newline never where dispatch "GET" ["register"] = getRegisterR >>= sendResponse dispatch "POST" ["register"] = postRegisterR >>= sendResponse + dispatch "GET" ["forgot-password"] = getForgotPasswordR >>= sendResponse + dispatch "POST" ["forgot-password"] = postForgotPasswordR >>= sendResponse dispatch "GET" ["verify", eid, verkey] = case fromPathPiece eid of Nothing -> notFound @@ -105,7 +170,7 @@ $newline never dispatch "POST" ["set-password"] = postPasswordR >>= sendResponse dispatch _ _ = notFound -getRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) RepHtml +getRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html getRegisterR = do email <- newIdent tp <- getRouteToParent @@ -114,38 +179,77 @@ getRegisterR = do [whamlet|

_{Msg.EnterEmail}

-