diff --git a/Yesod/Auth.hs b/Yesod/Auth.hs --- a/Yesod/Auth.hs +++ b/Yesod/Auth.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -15,6 +17,8 @@ , AuthPlugin (..) , getAuth , YesodAuth (..) + , YesodAuthPersist + , AuthEntity -- * Plugin interface , Creds (..) , setCreds @@ -26,11 +30,14 @@ , requireAuth -- * Exception , AuthException (..) + -- * Helper + , AuthHandler ) where -import Control.Monad (when) +import Control.Monad (when) import Control.Monad.Trans.Maybe +import Yesod.Auth.Routes import Data.Aeson import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) @@ -39,31 +46,28 @@ import qualified Data.HashMap.Lazy as Map import Network.HTTP.Conduit (Manager) -import Language.Haskell.TH.Syntax hiding (lift) - import qualified Network.Wai as W import Text.Hamlet (shamlet) import Yesod.Core import Yesod.Persist -import Yesod.Json import Yesod.Auth.Message (AuthMessage, defaultMessage) import qualified Yesod.Auth.Message as Msg import Yesod.Form (FormMessage) import Data.Typeable (Typeable) import Control.Exception (Exception) -data Auth = Auth - type AuthRoute = Route Auth +type AuthHandler master a = YesodAuth master => HandlerT Auth (HandlerT master IO) a + type Method = Text type Piece = Text data AuthPlugin master = AuthPlugin { apName :: Text - , apDispatch :: Method -> [Piece] -> GHandler Auth master () - , apLogin :: forall sub. (Route Auth -> Route master) -> GWidget sub master () + , apDispatch :: Method -> [Piece] -> AuthHandler master () + , apLogin :: (Route Auth -> Route master) -> WidgetT master IO () } getAuth :: a -> Auth @@ -88,23 +92,25 @@ logoutDest :: master -> Route master -- | Determine the ID associated with the set of credentials. - getAuthId :: Creds master -> GHandler sub master (Maybe (AuthId master)) + getAuthId :: Creds master -> HandlerT master IO (Maybe (AuthId master)) -- | Which authentication backends to use. authPlugins :: master -> [AuthPlugin master] -- | What to show on the login page. - loginHandler :: GHandler Auth master RepHtml - loginHandler = defaultLayout $ do - setTitleI Msg.LoginTitle - tm <- lift getRouteToMaster - master <- lift getYesod - mapM_ (flip apLogin tm) (authPlugins master) + loginHandler :: AuthHandler master RepHtml + loginHandler = do + tp <- getRouteToParent + lift $ defaultLayout $ do + setTitleI Msg.LoginTitle + master <- getYesod + mapM_ (flip apLogin tp) (authPlugins master) -- | Used for i18n of messages provided by this package. renderAuthMessage :: master -> [Text] -- ^ languages - -> AuthMessage -> Text + -> AuthMessage + -> Text renderAuthMessage _ _ = defaultMessage -- | After login and logout, redirect to the referring page, instead of @@ -115,16 +121,16 @@ -- | Return an HTTP connection manager that is stored in the foundation -- type. This allows backends to reuse persistent connections. If none of -- the backends you're using use HTTP connections, you can safely return - -- @error \"authHttpManager"@ here. + -- @error \"authHttpManager\"@ here. authHttpManager :: master -> Manager -- | Called on a successful login. By default, calls -- @setMessageI NowLoggedIn@. - onLogin :: GHandler sub master () + onLogin :: HandlerT master IO () onLogin = setMessageI Msg.NowLoggedIn -- | Called on logout. By default, does nothing - onLogout :: GHandler sub master () + onLogout :: HandlerT master IO () onLogout = return () -- | Retrieves user credentials, if user is authenticated. @@ -135,8 +141,20 @@ -- especially useful for creating an API to be accessed via some means -- other than a browser. -- - -- Since 1.1.2 - maybeAuthId :: GHandler sub master (Maybe (AuthId master)) + -- Since 1.2.0 + maybeAuthId :: HandlerT master IO (Maybe (AuthId master)) + + default maybeAuthId + :: ( YesodAuth master + , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val + , b ~ YesodPersistBackend master + , Key val ~ AuthId master + , PersistStore (b (HandlerT master IO)) + , PersistEntity val + , YesodPersist master + , Typeable val + ) + => HandlerT master IO (Maybe (AuthId master)) maybeAuthId = defaultMaybeAuthId credsKey :: Text @@ -144,57 +162,87 @@ -- | Retrieves user credentials from the session, if user is authenticated. -- +-- This function does /not/ confirm that the credentials are valid, see +-- 'maybeAuthIdRaw' for more information. +-- -- Since 1.1.2 -defaultMaybeAuthId :: YesodAuth master - => GHandler sub master (Maybe (AuthId master)) +defaultMaybeAuthId + :: ( YesodAuth master + , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val + , b ~ YesodPersistBackend master + , Key val ~ AuthId master + , PersistStore (b (HandlerT master IO)) + , PersistEntity val + , YesodPersist master + , Typeable val + ) => HandlerT master IO (Maybe (AuthId master)) defaultMaybeAuthId = do ms <- lookupSession credsKey case ms of Nothing -> return Nothing - Just s -> return $ fromPathPiece s + Just s -> + case fromPathPiece s of + Nothing -> return Nothing + Just aid -> fmap (fmap entityKey) $ cachedAuth aid -mkYesodSub "Auth" - [ ClassP ''YesodAuth [VarT $ mkName "master"] - ] -#define STRINGS *Texts - [parseRoutes| -/check CheckR GET -/login LoginR GET -/logout LogoutR GET POST -/page/#Text/STRINGS PluginR -|] +cachedAuth :: ( YesodAuth master + , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val + , b ~ YesodPersistBackend master + , Key val ~ AuthId master + , PersistStore (b (HandlerT master IO)) + , PersistEntity val + , YesodPersist master + , Typeable val + ) => AuthId master -> HandlerT master IO (Maybe (Entity val)) +cachedAuth aid = runMaybeT $ do + a <- MaybeT $ fmap unCachedMaybeAuth + $ cached + $ fmap CachedMaybeAuth + $ runDB + $ get aid + return $ Entity aid a -- | Sets user credentials for the session after checking them with authentication backends. setCreds :: YesodAuth master => Bool -- ^ if HTTP redirects should be done -> Creds master -- ^ new credentials - -> GHandler sub master () + -> HandlerT master IO () setCreds doRedirects creds = do y <- getYesod maid <- getAuthId creds case maid of - Nothing -> - when doRedirects $ do + Nothing -> when doRedirects $ do case authRoute y of - Nothing -> do rh <- defaultLayout $ toWidget [shamlet| -$newline never -

Invalid login -|] - sendResponse rh - Just ar -> do setMessageI Msg.InvalidLogin - redirect ar + Nothing -> do + res <- selectRep $ do + provideRep $ defaultLayout $ toWidget [shamlet|

Invalid login|] + provideRep $ return $ object ["message" .= ("Invalid Login" :: Text)] + sendResponse res + Just ar -> do + res <- selectRep $ do + provideRepType typeHtml $ do + setMessageI Msg.InvalidLogin + _ <- redirect ar + return () + provideRep $ return $ object ["message" .= ("Invalid Login" :: Text)] + sendResponse res Just aid -> do setSession credsKey $ toPathPiece aid when doRedirects $ do onLogin - redirectUltDest $ loginDest y + res <- selectRep $ do + provideRepType typeHtml $ do + _ <- redirectUltDest $ loginDest y + return () + provideRep $ return $ object ["message" .= ("Login Successful" :: Text)] + sendResponse res -- | Clears current user credentials for the session. -- -- Since 1.1.7 clearCreds :: YesodAuth master => Bool -- ^ if HTTP redirect to 'logoutDest' should be done - -> GHandler sub master () + -> HandlerT master IO () clearCreds doRedirects = do y <- getYesod deleteSession credsKey @@ -202,12 +250,12 @@ onLogout redirectUltDest $ logoutDest y -getCheckR :: YesodAuth master => GHandler Auth master RepHtmlJson -getCheckR = do +getCheckR :: AuthHandler master TypedContent +getCheckR = lift $ do creds <- maybeAuthId defaultLayoutJson (do setTitle "Authentication Status" - toWidget $ html' creds) (jsonCreds creds) + toWidget $ html' creds) (return $ jsonCreds creds) where html' creds = [shamlet| @@ -223,25 +271,23 @@ [ (T.pack "logged_in", Bool $ maybe False (const True) creds) ] -setUltDestReferer' :: YesodAuth master => GHandler sub master () -setUltDestReferer' = do +setUltDestReferer' :: AuthHandler master () +setUltDestReferer' = lift $ do master <- getYesod when (redirectToReferer master) setUltDestReferer -getLoginR :: YesodAuth master => GHandler Auth master RepHtml +getLoginR :: AuthHandler master RepHtml getLoginR = setUltDestReferer' >> loginHandler -getLogoutR :: YesodAuth master => GHandler Auth master () -getLogoutR = do - tm <- getRouteToMaster - setUltDestReferer' >> redirectToPost (tm LogoutR) +getLogoutR :: AuthHandler master () +getLogoutR = setUltDestReferer' >> redirectToPost LogoutR -postLogoutR :: YesodAuth master => GHandler Auth master () -postLogoutR = clearCreds True +postLogoutR :: AuthHandler master () +postLogoutR = lift $ clearCreds True -handlePluginR :: YesodAuth master => Text -> [Text] -> GHandler Auth master () +handlePluginR :: Text -> [Text] -> AuthHandler master () handlePluginR plugin pieces = do - master <- getYesod + master <- lift getYesod env <- waiRequest let method = decodeUtf8With lenientDecode $ W.requestMethod env case filter (\x -> apName x == plugin) (authPlugins master) of @@ -249,45 +295,58 @@ ap:_ -> apDispatch ap method pieces maybeAuth :: ( YesodAuth master -#if MIN_VERSION_persistent(1, 1, 0) - , PersistMonadBackend (b (GHandler sub master)) ~ PersistEntityBackend val + , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val , b ~ YesodPersistBackend master , Key val ~ AuthId master - , PersistStore (b (GHandler sub master)) -#else - , b ~ YesodPersistBackend master - , b ~ PersistEntityBackend val - , Key b val ~ AuthId master - , PersistStore b (GHandler sub master) -#endif + , PersistStore (b (HandlerT master IO)) , PersistEntity val , YesodPersist master - ) => GHandler sub master (Maybe (Entity val)) + , Typeable val + ) => HandlerT master IO (Maybe (Entity val)) maybeAuth = runMaybeT $ do - aid <- MaybeT $ maybeAuthId - a <- MaybeT $ runDB $ get aid - return $ Entity aid a + aid <- MaybeT maybeAuthId + MaybeT $ cachedAuth aid -requireAuthId :: YesodAuth master => GHandler sub master (AuthId master) +newtype CachedMaybeAuth val = CachedMaybeAuth { unCachedMaybeAuth :: Maybe val } + deriving Typeable + +-- | Constraint which states that the given site is an instance of @YesodAuth@ +-- and that its @AuthId@ is in fact a persistent @Key@ for the given value. +-- This is the common case in Yesod, and means that you can easily look up the +-- full informatin on a given user. +-- +-- Since 1.2.0 +type YesodAuthPersist master = + ( YesodAuth master + , PersistMonadBackend (YesodPersistBackend master (HandlerT master IO)) + ~ PersistEntityBackend (AuthEntity master) + , Key (AuthEntity master) ~ AuthId master + , PersistStore (YesodPersistBackend master (HandlerT master IO)) + , PersistEntity (AuthEntity master) + , YesodPersist master + , Typeable (AuthEntity master) + ) + +-- | If the @AuthId@ for a given site is a persistent ID, this will give the +-- value for that entity. E.g.: +-- +-- > type AuthId MySite = UserId +-- > AuthEntity MySite ~ User +-- +-- Since 1.2.0 +type AuthEntity master = KeyEntity (AuthId master) + +-- | Similar to 'maybeAuthId', but redirects to a login page if user is not +-- authenticated. +-- +-- Since 1.1.0 +requireAuthId :: YesodAuthPersist master => HandlerT master IO (AuthId master) requireAuthId = maybeAuthId >>= maybe redirectLogin return -requireAuth :: ( YesodAuth master - , b ~ YesodPersistBackend master -#if MIN_VERSION_persistent(1, 1, 0) - , PersistMonadBackend (b (GHandler sub master)) ~ PersistEntityBackend val - , Key val ~ AuthId master - , PersistStore (b (GHandler sub master)) -#else - , b ~ PersistEntityBackend val - , Key b val ~ AuthId master - , PersistStore b (GHandler sub master) -#endif - , PersistEntity val - , YesodPersist master - ) => GHandler sub master (Entity val) +requireAuth :: YesodAuthPersist master => HandlerT master IO (Entity (AuthEntity master)) requireAuth = maybeAuth >>= maybe redirectLogin return -redirectLogin :: Yesod master => GHandler sub master a +redirectLogin :: Yesod master => HandlerT master IO a redirectLogin = do y <- getYesod setUltDestCurrent @@ -302,3 +361,6 @@ | InvalidFacebookResponse deriving (Show, Typeable) instance Exception AuthException + +instance YesodAuth master => YesodSubDispatch Auth (HandlerT master IO) where + yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth) diff --git a/Yesod/Auth/BrowserId.hs b/Yesod/Auth/BrowserId.hs --- a/Yesod/Auth/BrowserId.hs +++ b/Yesod/Auth/BrowserId.hs @@ -1,10 +1,14 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} module Yesod.Auth.BrowserId ( authBrowserId - , authBrowserIdAudience , createOnClick + , def + , BrowserIdSettings + , bisAudience + , bisLazyLoad ) where import Yesod.Auth @@ -14,14 +18,13 @@ import Text.Hamlet (hamlet) import qualified Data.Text as T import Data.Maybe (fromMaybe) -import Control.Monad.IO.Class (liftIO) -import Control.Monad (when) +import Control.Monad (when, unless) import Control.Exception (throwIO) import Text.Julius (julius, rawJS) -import Data.Aeson (toJSON) import Network.URI (uriPath, parseURI) import Data.FileEmbed (embedFile) import Data.ByteString (ByteString) +import Data.Default pid :: Text pid = "browserid" @@ -29,38 +32,50 @@ complete :: Route Auth complete = PluginR pid [] --- | Log into browser ID with an audience value determined from the 'approot'. -authBrowserId :: YesodAuth m => AuthPlugin m -authBrowserId = helper Nothing +-- | A settings type for various configuration options relevant to BrowserID. +-- +-- See: +-- +-- Since 1.2.0 +data BrowserIdSettings = BrowserIdSettings + { bisAudience :: Maybe Text + -- ^ BrowserID audience value. If @Nothing@, will be extracted based on the + -- approot. + -- + -- Default: @Nothing@ + -- + -- Since 1.2.0 + , bisLazyLoad :: Bool + -- ^ Use asynchronous Javascript loading for the BrowserID JS file. + -- + -- Default: @True@. + -- + -- Since 1.2.0 + } --- | Log into browser ID with the given audience value. Note that this must be --- your actual hostname, or login will fail. -authBrowserIdAudience - :: YesodAuth m - => Text -- ^ audience - -> AuthPlugin m -authBrowserIdAudience = helper . Just +instance Default BrowserIdSettings where + def = BrowserIdSettings + { bisAudience = Nothing + , bisLazyLoad = True + } -helper :: YesodAuth m - => Maybe Text -- ^ audience - -> AuthPlugin m -helper maudience = AuthPlugin +authBrowserId :: YesodAuth m => BrowserIdSettings -> AuthPlugin m +authBrowserId bis@BrowserIdSettings {..} = AuthPlugin { apName = pid , apDispatch = \m ps -> case (m, ps) of ("GET", [assertion]) -> do - master <- getYesod + master <- lift getYesod audience <- - case maudience of + case bisAudience of Just a -> return a Nothing -> do - tm <- getRouteToMaster r <- getUrlRender - return $ T.takeWhile (/= '/') $ stripScheme $ r $ tm LoginR + return $ T.takeWhile (/= '/') $ stripScheme $ r LoginR memail <- lift $ checkAssertion audience assertion (authHttpManager master) case memail of Nothing -> liftIO $ throwIO InvalidBrowserIDAssertion - Just email -> setCreds True Creds + Just email -> lift $ setCreds True Creds { credsPlugin = pid , credsIdent = email , credsExtra = [] @@ -72,12 +87,10 @@ (_, []) -> badMethod _ -> notFound , apLogin = \toMaster -> do - onclick <- createOnClick toMaster + onclick <- createOnClick bis toMaster - autologin <- fmap (== Just "true") $ lift $ lookupGetParam "autologin" - when autologin $ toWidget [julius| -#{rawJS onclick}(); -|] + autologin <- fmap (== Just "true") $ lookupGetParam "autologin" + when autologin $ toWidget [julius|#{rawJS onclick}();|] toWidget [hamlet| $newline never @@ -92,29 +105,45 @@ -- | Generates a function to handle on-click events, and returns that function -- name. -createOnClick :: (Route Auth -> Route master) -> GWidget sub master Text -createOnClick toMaster = do - addScriptRemote browserIdJs - onclick <- lift newIdent - render <- lift getUrlRender +createOnClick :: BrowserIdSettings + -> (Route Auth -> Route master) + -> WidgetT master IO Text +createOnClick BrowserIdSettings {..} toMaster = do + unless bisLazyLoad $ addScriptRemote browserIdJs + onclick <- newIdent + render <- getUrlRender let login = toJSON $ getPath $ render (toMaster LoginR) toWidget [julius| function #{rawJS onclick}() { - navigator.id.watch({ - onlogin: function (assertion) { - if (assertion) { - document.location = "@{toMaster complete}/" + assertion; - } - }, - onlogout: function () {} - }); - navigator.id.request({ - returnTo: #{login} + "?autologin=true" - }); + if (navigator.id) { + navigator.id.watch({ + onlogin: function (assertion) { + if (assertion) { + document.location = "@{toMaster complete}/" + assertion; + } + }, + onlogout: function () {} + }); + navigator.id.request({ + returnTo: #{login} + "?autologin=true" + }); + } + else { + alert("Loading, please try again"); + } } |] + when bisLazyLoad $ toWidget [julius| + (function(){ + var bid = document.createElement("script"); + bid.async = true; + bid.src = #{toJSON browserIdJs}; + var s = document.getElementsByTagName('script')[0]; + s.parentNode.insertBefore(bid, s); + })(); + |] - autologin <- fmap (== Just "true") $ lift $ lookupGetParam "autologin" + autologin <- fmap (== Just "true") $ lookupGetParam "autologin" when autologin $ toWidget [julius|#{rawJS onclick}();|] return onclick where diff --git a/Yesod/Auth/Dummy.hs b/Yesod/Auth/Dummy.hs --- a/Yesod/Auth/Dummy.hs +++ b/Yesod/Auth/Dummy.hs @@ -9,17 +9,16 @@ import Yesod.Auth import Yesod.Form (runInputPost, textField, ireq) -import Yesod.Handler (notFound) import Text.Hamlet (hamlet) -import Yesod.Widget (toWidget) +import Yesod.Core authDummy :: YesodAuth m => AuthPlugin m authDummy = AuthPlugin "dummy" dispatch login where dispatch "POST" [] = do - ident <- runInputPost $ ireq textField "ident" - setCreds True $ Creds "dummy" ident [] + ident <- lift $ runInputPost $ ireq textField "ident" + lift $ setCreds True $ Creds "dummy" ident [] dispatch _ _ = notFound url = PluginR "dummy" [] login authToMaster = diff --git a/Yesod/Auth/Email.hs b/Yesod/Auth/Email.hs --- a/Yesod/Auth/Email.hs +++ b/Yesod/Auth/Email.hs @@ -1,6 +1,7 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternGuards #-} module Yesod.Auth.Email ( -- * Plugin authEmail @@ -10,33 +11,40 @@ -- * 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 Yesod.Core import qualified Crypto.PasswordStore as PS -import qualified Data.Text.Encoding as DTE - -import Yesod.Form -import Yesod.Handler -import Yesod.Content -import Yesod.Core (PathPiece, fromPathPiece, whamlet, defaultLayout, setTitleI, toPathPiece) -import Control.Monad.IO.Class (liftIO) +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 @@ -48,33 +56,86 @@ 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 m, PathPiece (AuthEmailId m)) => YesodAuthEmail m where - type AuthEmailId m +class (YesodAuth site, PathPiece (AuthEmailId site)) => YesodAuthEmail site where + type AuthEmailId site - addUnverified :: Email -> VerKey -> GHandler Auth m (AuthEmailId m) - sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler Auth m () - getVerifyKey :: AuthEmailId m -> GHandler Auth m (Maybe VerKey) - setVerifyKey :: AuthEmailId m -> VerKey -> GHandler Auth m () - verifyAccount :: AuthEmailId m -> GHandler Auth m (Maybe (AuthId m)) - getPassword :: AuthId m -> GHandler Auth m (Maybe SaltedPass) - setPassword :: AuthId m -> SaltedPass -> GHandler Auth m () - getEmailCreds :: Email -> GHandler Auth m (Maybe (EmailCreds m)) - getEmail :: AuthEmailId m -> GHandler Auth m (Maybe Email) + -- | 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 () + + -- | 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. - randomKey :: m -> IO Text + -- + -- 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 -> @@ -98,6 +159,8 @@ 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 @@ -107,113 +170,157 @@ dispatch "POST" ["set-password"] = postPasswordR >>= sendResponse dispatch _ _ = notFound -getRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml +getRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html getRegisterR = do - toMaster <- getRouteToMaster email <- newIdent - defaultLayout $ do + tp <- getRouteToParent + lift $ defaultLayout $ do setTitleI Msg.RegisterLong [whamlet| -$newline never -

_{Msg.EnterEmail} -

-