yesod-auth 1.1.7 → 1.2.0
raw patch · 11 files changed
+667/−373 lines, 11 filesdep +data-defaultdep +email-validatedep −yesod-jsondep ~persistentdep ~persistent-templatedep ~wai
Dependencies added: data-default, email-validate
Dependencies removed: yesod-json
Dependency ranges changed: persistent, persistent-template, wai, yesod-core, yesod-form, yesod-persistent
Files
- Yesod/Auth.hs +151/−89
- Yesod/Auth/BrowserId.hs +74/−45
- Yesod/Auth/Dummy.hs +3/−4
- Yesod/Auth/Email.hs +211/−107
- Yesod/Auth/GoogleEmail.hs +12/−23
- Yesod/Auth/HashDB.hs +16/−61
- Yesod/Auth/Message.hs +149/−2
- Yesod/Auth/OpenId.hs +14/−23
- Yesod/Auth/Routes.hs +20/−0
- Yesod/Auth/Rpxnow.hs +4/−10
- yesod-auth.cabal +13/−9
Yesod/Auth.hs view
@@ -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-<h1>Invalid login-|]- sendResponse rh- Just ar -> do setMessageI Msg.InvalidLogin- redirect ar+ Nothing -> do+ res <- selectRep $ do+ provideRep $ defaultLayout $ toWidget [shamlet|<h1>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)
Yesod/Auth/BrowserId.hs view
@@ -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: <http://www.yesodweb.com/book/settings-types>+--+-- 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
Yesod/Auth/Dummy.hs view
@@ -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 =
Yesod/Auth/Email.hs view
@@ -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-<p>_{Msg.EnterEmail}-<form method="post" action="@{toMaster registerR}">- <label for=#{email}>_{Msg.Email}- <input ##{email} type="email" name="email" width="150">- <input type="submit" value=_{Msg.Register}>-|]+ <p>_{Msg.EnterEmail}+ <form method="post" action="@{tp registerR}">+ <div id="registerForm">+ <label for=#{email}>_{Msg.Email}:+ <input ##{email} type="email" name="email" width="150">+ <button .btn>_{Msg.Register}+ |] -postRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml-postRegisterR = do- y <- getYesod- email <- runInputPost $ ireq emailField "email"- mecreds <- getEmailCreds email- (lid, verKey) <-- case mecreds of- Just (EmailCreds lid _ _ (Just key)) -> return (lid, key)- Just (EmailCreds lid _ _ Nothing) -> do- key <- liftIO $ randomKey y- setVerifyKey lid key- return (lid, key)+registerHelper :: YesodAuthEmail master+ => Bool -- ^ allow usernames?+ -> Route Auth+ -> HandlerT Auth (HandlerT master IO) Html+registerHelper allowUsername dest = do+ y <- lift getYesod+ midentifier <- lookupPostParam "email"+ identifier <-+ case midentifier of Nothing -> do+ lift $ setMessageI Msg.NoIdentifierProvided+ redirect dest+ Just x+ | Just x' <- Text.Email.Validate.canonicalizeEmail (encodeUtf8 x) ->+ return $ decodeUtf8With lenientDecode x'+ | allowUsername -> return $ TS.strip x+ | otherwise -> do+ lift $ setMessageI Msg.InvalidEmailAddress+ redirect dest+ mecreds <- lift $ getEmailCreds identifier+ (lid, verKey, email) <-+ case mecreds of+ Just (EmailCreds lid _ _ (Just key) email) -> return (lid, key, email)+ Just (EmailCreds lid _ _ Nothing email) -> do key <- liftIO $ randomKey y- lid <- addUnverified email key- return (lid, key)+ lift $ setVerifyKey lid key+ return (lid, key, email)+ Nothing+ | allowUsername -> do+ setMessage $ toHtml $ "No record for that identifier in our database: " `TS.append` identifier+ redirect dest+ | otherwise -> do+ key <- liftIO $ randomKey y+ lid <- lift $ addUnverified identifier key+ return (lid, key, identifier) render <- getUrlRender- tm <- getRouteToMaster- let verUrl = render $ tm $ verify (toPathPiece lid) verKey- sendVerifyEmail email verKey verUrl- defaultLayout $ do+ let verUrl = render $ verify (toPathPiece lid) verKey+ lift $ sendVerifyEmail email verKey verUrl+ lift $ defaultLayout $ do setTitleI Msg.ConfirmationEmailSentTitle+ [whamlet|<p>_{Msg.ConfirmationEmailSent identifier}|]++postRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html+postRegisterR = registerHelper False registerR++getForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html+getForgotPasswordR = do+ tp <- getRouteToParent+ email <- newIdent+ lift $ defaultLayout $ do+ setTitleI Msg.PasswordResetTitle [whamlet|-$newline never-<p>_{Msg.ConfirmationEmailSent email}-|]+ <p>_{Msg.PasswordResetPrompt}+ <form method="post" action="@{tp forgotPasswordR}">+ <div id="registerForm">+ <label for=#{email}>_{Msg.ProvideIdentifier}+ <input ##{email} type=text name="email" width="150">+ <button .btn>_{Msg.SendPasswordResetEmail}+ |] +postForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html+postForgotPasswordR = registerHelper True forgotPasswordR+ getVerifyR :: YesodAuthEmail m- => AuthEmailId m -> Text -> GHandler Auth m RepHtml+ => AuthEmailId m -> Text -> HandlerT Auth (HandlerT m IO) Html getVerifyR lid key = do- realKey <- getVerifyKey lid- memail <- getEmail lid+ realKey <- lift $ getVerifyKey lid+ memail <- lift $ getEmail lid case (realKey == Just key, memail) of (True, Just email) -> do- muid <- verifyAccount lid+ muid <- lift $ verifyAccount lid case muid of Nothing -> return () Just _uid -> do- setCreds False $ Creds "email" email [("verifiedEmail", email)] -- FIXME uid?- toMaster <- getRouteToMaster- setMessageI Msg.AddressVerified- redirect $ toMaster setpassR+ lift $ setCreds False $ Creds "email-verify" email [("verifiedEmail", email)] -- FIXME uid?+ lift $ setMessageI Msg.AddressVerified+ redirect setpassR _ -> return ()- defaultLayout $ do+ lift $ defaultLayout $ do setTitleI Msg.InvalidKey [whamlet| $newline never <p>_{Msg.InvalidKey} |] -postLoginR :: YesodAuthEmail master => GHandler Auth master ()+postLoginR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) () postLoginR = do- (email, pass) <- runInputPost $ (,)- <$> ireq emailField "email"+ (identifier, pass) <- lift $ runInputPost $ (,)+ <$> ireq textField "email" <*> ireq textField "password"- mecreds <- getEmailCreds email+ mecreds <- lift $ getEmailCreds identifier maid <-- case (mecreds >>= emailCredsAuthId, fmap emailCredsStatus mecreds) of- (Just aid, Just True) -> do- mrealpass <- getPassword aid+ case ( mecreds >>= emailCredsAuthId+ , emailCredsEmail <$> mecreds+ , emailCredsStatus <$> mecreds+ ) of+ (Just aid, Just email, Just True) -> do+ mrealpass <- lift $ getPassword aid case mrealpass of Nothing -> return Nothing Just realpass -> return $ if isValidPass pass realpass- then Just aid+ then Just email else Nothing _ -> return Nothing+ let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier case maid of- Just _aid ->- setCreds True $ Creds "email" email [("verifiedEmail", email)] -- FIXME aid?+ Just email ->+ lift $ setCreds True $ Creds+ (if isEmail then "email" else "username")+ email+ [("verifiedEmail", email)] Nothing -> do- setMessageI Msg.InvalidEmailPass- toMaster <- getRouteToMaster- redirect $ toMaster LoginR+ lift $ setMessageI $+ if isEmail+ then Msg.InvalidEmailPass+ else Msg.InvalidUsernamePass+ redirect LoginR -getPasswordR :: YesodAuthEmail master => GHandler Auth master RepHtml+getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html getPasswordR = do- toMaster <- getRouteToMaster- maid <- maybeAuthId+ maid <- lift maybeAuthId pass1 <- newIdent pass2 <- newIdent case maid of Just _ -> return () Nothing -> do- setMessageI Msg.BadSetPass- redirect $ toMaster LoginR- defaultLayout $ do+ lift $ setMessageI Msg.BadSetPass+ redirect LoginR+ tp <- getRouteToParent+ lift $ defaultLayout $ do setTitleI Msg.SetPassTitle [whamlet| $newline never <h3>_{Msg.SetPass}-<form method="post" action="@{toMaster setpassR}">+<form method="post" action="@{tp setpassR}"> <table> <tr> <th>@@ -227,50 +334,47 @@ <input ##{pass2} type="password" name="confirm"> <tr> <td colspan="2">- <input type="submit" value="_{Msg.SetPassTitle}">+ <input type="submit" value=_{Msg.SetPassTitle}> |] -postPasswordR :: YesodAuthEmail master => GHandler Auth master ()+postPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) () postPasswordR = do- (new, confirm) <- runInputPost $ (,)+ (new, confirm) <- lift $ runInputPost $ (,) <$> ireq textField "new" <*> ireq textField "confirm"- toMaster <- getRouteToMaster- y <- getYesod when (new /= confirm) $ do- setMessageI Msg.PassMismatch- redirect $ toMaster setpassR- maid <- maybeAuthId+ lift $ setMessageI Msg.PassMismatch+ redirect setpassR+ maid <- lift maybeAuthId aid <- case maid of Nothing -> do- setMessageI Msg.BadSetPass- redirect $ toMaster LoginR+ lift $ setMessageI Msg.BadSetPass+ redirect LoginR Just aid -> return aid salted <- liftIO $ saltPass new- setPassword aid salted- setMessageI Msg.PassUpdated- redirect $ loginDest y+ lift $ do+ y <- getYesod+ setPassword aid salted+ setMessageI Msg.PassUpdated+ redirect $ afterPasswordRoute y saltLength :: Int saltLength = 5 -- | Salt a password with a randomly generated salt. saltPass :: Text -> IO Text-saltPass = fmap DTE.decodeUtf8+saltPass = fmap (decodeUtf8With lenientDecode) . flip PS.makePassword 12- . DTE.encodeUtf8+ . encodeUtf8 saltPass' :: String -> String -> String-saltPass' salt pass =- salt ++ show (md5 $ fromString $ salt ++ pass)- where- fromString = encodeUtf8 . T.pack+saltPass' salt pass = salt ++ show (md5 $ TLE.encodeUtf8 $ TL.pack $ salt ++ pass) isValidPass :: Text -- ^ cleartext password -> SaltedPass -- ^ salted password -> Bool isValidPass ct salted =- PS.verifyPassword (DTE.encodeUtf8 ct) (DTE.encodeUtf8 salted) || isValidPass' ct salted+ PS.verifyPassword (encodeUtf8 ct) (encodeUtf8 salted) || isValidPass' ct salted isValidPass' :: Text -- ^ cleartext password -> SaltedPass -- ^ salted password
Yesod/Auth/GoogleEmail.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-} -- | Use an email address as an identifier via Google's OpenID login system. -- -- This backend will not use the OpenID identifier at all. It only uses OpenID@@ -18,14 +19,7 @@ import Yesod.Auth import qualified Web.Authenticate.OpenId as OpenId -import Yesod.Handler-import Yesod.Widget (whamlet)-import Yesod.Request-#if MIN_VERSION_blaze_html(0, 5, 0)-import Text.Blaze.Html (toHtml)-#else-import Text.Blaze (toHtml)-#endif+import Yesod.Core import Data.Text (Text) import qualified Yesod.Auth.Message as Msg import qualified Data.Text as T@@ -46,15 +40,11 @@ where complete = PluginR pid ["complete"] login tm =- [whamlet|-$newline never-<a href=@{tm forwardUrl}>_{Msg.LoginGoogle}-|]+ [whamlet|<a href=@{tm forwardUrl}>_{Msg.LoginGoogle}|] dispatch "GET" ["forward"] = do render <- getUrlRender- toMaster <- getRouteToMaster- let complete' = render $ toMaster complete- master <- getYesod+ let complete' = render complete+ master <- lift getYesod eres <- lift $ try $ OpenId.getForwardUrl googleIdent complete' Nothing [ ("openid.ax.type.email", "http://schema.openid.net/contact/email") , ("openid.ns.ax", "http://openid.net/srv/ax/1.0")@@ -66,7 +56,7 @@ either (\err -> do setMessage $ toHtml $ show (err :: SomeException)- redirect $ toMaster LoginR+ redirect LoginR ) redirect eres@@ -80,23 +70,22 @@ completeHelper posts dispatch _ _ = notFound -completeHelper :: YesodAuth m => [(Text, Text)] -> GHandler Auth m ()+completeHelper :: YesodAuth master => [(Text, Text)] -> AuthHandler master () completeHelper gets' = do- master <- getYesod+ master <- lift getYesod eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)- toMaster <- getRouteToMaster let onFailure err = do setMessage $ toHtml $ show (err :: SomeException)- redirect $ toMaster LoginR+ redirect LoginR let onSuccess oir = do let OpenId.Identifier ident = OpenId.oirOpLocal oir memail <- lookupGetParam "openid.ext1.value.email" case (memail, "https://www.google.com/accounts/o8/id" `T.isPrefixOf` ident) of- (Just email, True) -> setCreds True $ Creds pid email []+ (Just email, True) -> lift $ setCreds True $ Creds pid email [] (_, False) -> do setMessage "Only Google login is supported"- redirect $ toMaster LoginR+ redirect LoginR (Nothing, _) -> do setMessage "No email address provided"- redirect $ toMaster LoginR+ redirect LoginR either onFailure onSuccess eres
Yesod/Auth/HashDB.hs view
@@ -74,15 +74,13 @@ ) where import Yesod.Persist-import Yesod.Handler import Yesod.Form import Yesod.Auth-import Yesod.Widget (toWidget)+import Yesod.Core import Text.Hamlet (hamlet) import Control.Applicative ((<$>), (<*>)) import Control.Monad (replicateM,liftM)-import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Data.ByteString.Lazy.Char8 as BS (pack) import Data.Digest.Pure.SHA (sha1, showDigest)@@ -135,26 +133,15 @@ -- | Given a user ID and password in plaintext, validate them against -- the database values. validateUser :: ( YesodPersist yesod-#if MIN_VERSION_persistent(1, 1, 0) , b ~ YesodPersistBackend yesod- , PersistMonadBackend (b (GHandler sub yesod)) ~ PersistEntityBackend user- , PersistUnique (b (GHandler sub yesod))-#else- , b ~ YesodPersistBackend yesod- , b ~ PersistEntityBackend user- , PersistStore b (GHandler sub yesod)- , PersistUnique b (GHandler sub yesod)-#endif+ , PersistMonadBackend (b (HandlerT yesod IO)) ~ PersistEntityBackend user+ , PersistUnique (b (HandlerT yesod IO)) , PersistEntity user , HashDBUser user ) => -#if MIN_VERSION_persistent(1, 1, 0) Unique user -- ^ User unique identifier-#else- Unique user b -- ^ User unique identifier-#endif -> Text -- ^ Password in plaint-text- -> GHandler sub yesod Bool+ -> HandlerT yesod IO Bool validateUser userID passwd = do -- Checks that hash and password match let validate u = do hash <- userPasswordHash u@@ -173,62 +160,38 @@ -- username (whatever it might be) to unique user ID. postLoginR :: ( YesodAuth y, YesodPersist y , HashDBUser user, PersistEntity user-#if MIN_VERSION_persistent(1, 1, 0) , b ~ YesodPersistBackend y- , PersistMonadBackend (b (GHandler Auth y)) ~ PersistEntityBackend user- , PersistUnique (b (GHandler Auth y))-#else- , b ~ YesodPersistBackend y- , b ~ PersistEntityBackend user- , PersistStore b (GHandler Auth y)- , PersistUnique b (GHandler Auth y)-#endif+ , PersistMonadBackend (b (HandlerT y IO)) ~ PersistEntityBackend user+ , PersistUnique (b (HandlerT y IO)) )-#if MIN_VERSION_persistent(1, 1, 0) => (Text -> Maybe (Unique user))-#else- => (Text -> Maybe (Unique user b))-#endif- -> GHandler Auth y ()+ -> HandlerT Auth (HandlerT y IO) () postLoginR uniq = do- (mu,mp) <- runInputPost $ (,)+ (mu,mp) <- lift $ runInputPost $ (,) <$> iopt textField "username" <*> iopt textField "password" - isValid <- fromMaybe (return False) + isValid <- lift $ fromMaybe (return False) (validateUser <$> (uniq =<< mu) <*> mp) if isValid - then setCreds True $ Creds "hashdb" (fromMaybe "" mu) []+ then lift $ setCreds True $ Creds "hashdb" (fromMaybe "" mu) [] else do setMessage "Invalid username/password"- toMaster <- getRouteToMaster- redirect $ toMaster LoginR+ redirect LoginR -- | A drop in for the getAuthId method of your YesodAuth instance which -- can be used if authHashDB is the only plugin in use. getAuthIdHashDB :: ( YesodAuth master, YesodPersist master , HashDBUser user, PersistEntity user-#if MIN_VERSION_persistent(1, 1, 0) , Key user ~ AuthId master , b ~ YesodPersistBackend master- , PersistMonadBackend (b (GHandler sub master)) ~ PersistEntityBackend user- , PersistUnique (b (GHandler sub master))-#else- , Key b user ~ AuthId master- , b ~ YesodPersistBackend master- , b ~ PersistEntityBackend user- , PersistUnique b (GHandler sub master)- , PersistStore b (GHandler sub master)-#endif+ , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend user+ , PersistUnique (b (HandlerT master IO)) ) => (AuthRoute -> Route master) -- ^ your site's Auth Route-#if MIN_VERSION_persistent(1, 1, 0) -> (Text -> Maybe (Unique user)) -- ^ gets user ID-#else- -> (Text -> Maybe (Unique user b)) -- ^ gets user ID-#endif -> Creds master -- ^ the creds argument- -> GHandler sub master (Maybe (AuthId master))+ -> HandlerT master IO (Maybe (AuthId master)) getAuthIdHashDB authR uniq creds = do muid <- maybeAuthId case muid of@@ -250,18 +213,10 @@ authHashDB :: ( YesodAuth m, YesodPersist m , HashDBUser user , PersistEntity user-#if MIN_VERSION_persistent(1, 1, 0) , b ~ YesodPersistBackend m- , PersistMonadBackend (b (GHandler Auth m)) ~ PersistEntityBackend user- , PersistUnique (b (GHandler Auth m)))+ , PersistMonadBackend (b (HandlerT m IO)) ~ PersistEntityBackend user+ , PersistUnique (b (HandlerT m IO))) => (Text -> Maybe (Unique user)) -> AuthPlugin m-#else- , b ~ YesodPersistBackend m- , b ~ PersistEntityBackend user- , PersistStore b (GHandler Auth m)- , PersistUnique b (GHandler Auth m))- => (Text -> Maybe (Unique user b)) -> AuthPlugin m-#endif authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> toWidget [hamlet| $newline never <div id="header">
Yesod/Auth/Message.hs view
@@ -12,6 +12,8 @@ , norwegianBokmålMessage , japaneseMessage , finnishMessage+ , chineseMessage+ , spanishMessage ) where import Data.Monoid (mappend)@@ -47,6 +49,13 @@ | LoginTitle | PleaseProvideUsername | PleaseProvidePassword+ | NoIdentifierProvided+ | InvalidEmailAddress+ | PasswordResetTitle+ | ProvideIdentifier+ | SendPasswordResetEmail+ | PasswordResetPrompt+ | InvalidUsernamePass -- | Defaults to 'englishMessage'. defaultMessage :: AuthMessage -> Text@@ -85,6 +94,13 @@ englishMessage LoginTitle = "Login" englishMessage PleaseProvideUsername = "Please fill in your username" englishMessage PleaseProvidePassword = "Please fill in your password"+englishMessage NoIdentifierProvided = "No email/username provided"+englishMessage InvalidEmailAddress = "Invalid email address provided"+englishMessage PasswordResetTitle = "Password Reset"+englishMessage ProvideIdentifier = "Email or Username"+englishMessage SendPasswordResetEmail = "Send password reset email"+englishMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."+englishMessage InvalidUsernamePass = "Invalid username/password combination" portugueseMessage :: AuthMessage -> Text portugueseMessage NoOpenID = "Nenhum identificador OpenID encontrado"@@ -119,7 +135,55 @@ portugueseMessage LoginTitle = "Entrar no site" portugueseMessage PleaseProvideUsername = "Por favor digite seu nome de usuário" portugueseMessage PleaseProvidePassword = "Por favor digite sua senha"+portugueseMessage NoIdentifierProvided = "Nenhum e-mail ou nome de usuário informado"+portugueseMessage InvalidEmailAddress = "Endereço de e-mail inválido informado"+portugueseMessage PasswordResetTitle = "Resetar senha"+portugueseMessage ProvideIdentifier = "E-mail ou nome de usuário"+portugueseMessage SendPasswordResetEmail = "Enviar e-mail para resetar senha"+portugueseMessage PasswordResetPrompt = "Insira seu endereço de e-mail ou nome de usuário abaixo. Um e-mail para resetar sua senha será enviado para você."+portugueseMessage InvalidUsernamePass = "Nome de usuário ou senha inválidos" +spanishMessage :: AuthMessage -> Text+spanishMessage NoOpenID = "No se encuentra el identificador OpenID"+spanishMessage LoginOpenID = "Entrar utilizando OpenID"+spanishMessage LoginGoogle = "Entrar utilizando Google"+spanishMessage LoginYahoo = "Entrar utilizando Yahoo"+spanishMessage Email = "Correo electrónico"+spanishMessage Password = "Contraseña"+spanishMessage Register = "Registrarse"+spanishMessage RegisterLong = "Registrar una nueva cuenta"+spanishMessage EnterEmail = "Coloque su dirección de correo electrónico, y un correo de confirmación le será enviado a su cuenta."+spanishMessage ConfirmationEmailSentTitle = "La confirmación de correo ha sido enviada"+spanishMessage (ConfirmationEmailSent email) =+ "Una confirmación de correo electrónico ha sido enviada a " `mappend`+ email `mappend`+ "."+spanishMessage AddressVerified = "Dirección verificada, por favor introduzca una contraseña"+spanishMessage InvalidKeyTitle = "Clave de verificación invalida"+spanishMessage InvalidKey = "Lo sentimos, pero esa clave de verificación es inválida."+spanishMessage InvalidEmailPass = "La combinación cuenta de correo/contraseña es inválida"+spanishMessage BadSetPass = "Debe acceder a la aplicación para modificar la contraseña"+spanishMessage SetPassTitle = "Modificar contraseña"+spanishMessage SetPass = "Actualizar nueva contraseña"+spanishMessage NewPass = "Nueva contraseña"+spanishMessage ConfirmPass = "Confirmar"+spanishMessage PassMismatch = "Las contraseñas no coinciden, inténtelo de nuevo"+spanishMessage PassUpdated = "Contraseña actualizada"+spanishMessage Facebook = "Entrar mediante Facebook"+spanishMessage LoginViaEmail = "Entrar mediante una cuenta de correo"+spanishMessage InvalidLogin = "Login inválido"+spanishMessage NowLoggedIn = "Usted ha ingresado al sitio"+spanishMessage LoginTitle = "Login"+spanishMessage PleaseProvideUsername = "Por favor escriba su nombre de usuario"+spanishMessage PleaseProvidePassword = "Por favor escriba su contraseña"+spanishMessage NoIdentifierProvided = "No ha indicado una cuenta de correo/nombre de usuario"+spanishMessage InvalidEmailAddress = "La cuenta de correo es inválida"+spanishMessage PasswordResetTitle = "Contraseña actualizada"+spanishMessage ProvideIdentifier = "Cuenta de correo o nombre de usuario"+spanishMessage SendPasswordResetEmail = "Correo de actualización de contraseña enviado"+spanishMessage PasswordResetPrompt = "Escriba su cuenta de correo o nombre de usuario, y una confirmación de actualización de contraseña será enviada a su cuenta de correo."+spanishMessage InvalidUsernamePass = "Combinación de nombre de usuario/contraseña invalida"+ swedishMessage :: AuthMessage -> Text swedishMessage NoOpenID = "Fann ej OpenID identifierare" swedishMessage LoginOpenID = "Logga in via OpenID"@@ -153,6 +217,14 @@ swedishMessage LoginTitle = "Logga in" swedishMessage PleaseProvideUsername = "Vänligen fyll i användarnamn" swedishMessage PleaseProvidePassword = "Vänligen fyll i lösenord"+swedishMessage NoIdentifierProvided = "Emailadress eller användarnamn saknas"+swedishMessage InvalidEmailAddress = "Ogiltig emailadress angiven"+swedishMessage PasswordResetTitle = "Återställning av lösenord"+swedishMessage ProvideIdentifier = "Epost eller användarnamn"+swedishMessage SendPasswordResetEmail = "Skicka email för återställning av lösenord"+swedishMessage PasswordResetPrompt = "Skriv in din emailadress eller användarnamn nedan och " `mappend`+ "ett email för återställning av lösenord kommmer att skickas till dig."+swedishMessage InvalidUsernamePass = "Ogiltig kombination av användarnamn och lösenord" germanMessage :: AuthMessage -> Text germanMessage NoOpenID = "Kein OpenID-Identifier gefunden"@@ -187,8 +259,13 @@ germanMessage LoginTitle = "Login" germanMessage PleaseProvideUsername = "Bitte Nutzername angeben" germanMessage PleaseProvidePassword = "Bitte Passwort angeben"--+germanMessage NoIdentifierProvided = "Keine Email-Adresse oder kein Nutzername angegeben"+germanMessage InvalidEmailAddress = "Unzulässiger Email-Anbieter"+germanMessage PasswordResetTitle = "Passwort zurücksetzen"+germanMessage ProvideIdentifier = "Email-Adresse oder Nutzername"+germanMessage SendPasswordResetEmail = "Email zusenden um Passwort zurückzusetzen"+germanMessage PasswordResetPrompt = "Nach Einhabe der Email-Adresse oder des Nutzernamen wird eine Email zugesendet mit welcher das Passwort zurückgesetzt werden kann."+germanMessage InvalidUsernamePass = "Ungültige Kombination aus Nutzername und Passwort" frenchMessage :: AuthMessage -> Text frenchMessage NoOpenID = "Aucun fournisseur OpenID n'a été trouvé"@@ -223,6 +300,13 @@ frenchMessage LoginTitle = "Se connecter" frenchMessage PleaseProvideUsername = "Merci de renseigner votre nom d'utilisateur" frenchMessage PleaseProvidePassword = "Merci de spécifier un mot de passe"+frenchMessage NoIdentifierProvided = "No email/username provided"+frenchMessage InvalidEmailAddress = "Invalid email address provided"+frenchMessage PasswordResetTitle = "Password Reset"+frenchMessage ProvideIdentifier = "Email or Username"+frenchMessage SendPasswordResetEmail = "Send password reset email"+frenchMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."+frenchMessage InvalidUsernamePass = "Invalid username/password combination" norwegianBokmålMessage :: AuthMessage -> Text norwegianBokmålMessage NoOpenID = "Ingen OpenID-identifiserer funnet"@@ -257,6 +341,13 @@ norwegianBokmålMessage LoginTitle = "Logg inn" norwegianBokmålMessage PleaseProvideUsername = "Vennligst fyll inn ditt brukernavn" norwegianBokmålMessage PleaseProvidePassword = "Vennligst fyll inn ditt passord"+norwegianBokmålMessage NoIdentifierProvided = "No email/username provided"+norwegianBokmålMessage InvalidEmailAddress = "Invalid email address provided"+norwegianBokmålMessage PasswordResetTitle = "Password Reset"+norwegianBokmålMessage ProvideIdentifier = "Email or Username"+norwegianBokmålMessage SendPasswordResetEmail = "Send password reset email"+norwegianBokmålMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."+norwegianBokmålMessage InvalidUsernamePass = "Invalid username/password combination" japaneseMessage :: AuthMessage -> Text japaneseMessage NoOpenID = "OpenID識別子がありません"@@ -291,6 +382,13 @@ japaneseMessage LoginTitle = "ログイン" japaneseMessage PleaseProvideUsername = "ユーザ名を入力してください" japaneseMessage PleaseProvidePassword = "パスワードを入力してください"+japaneseMessage NoIdentifierProvided = "No email/username provided"+japaneseMessage InvalidEmailAddress = "Invalid email address provided"+japaneseMessage PasswordResetTitle = "Password Reset"+japaneseMessage ProvideIdentifier = "Email or Username"+japaneseMessage SendPasswordResetEmail = "Send password reset email"+japaneseMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."+japaneseMessage InvalidUsernamePass = "Invalid username/password combination" finnishMessage :: AuthMessage -> Text finnishMessage NoOpenID = "OpenID-tunnistetta ei löydy"@@ -307,6 +405,7 @@ "Vahvistussähköposti on lähetty osoitteeseen " `mappend` email `mappend` "."+ finnishMessage AddressVerified = "Sähköpostiosoite vahvistettu. Anna uusi salasana" finnishMessage InvalidKeyTitle = "Virheellinen varmistusavain" finnishMessage InvalidKey = "Valitettavasti varmistusavain on virheellinen."@@ -325,5 +424,53 @@ finnishMessage LoginTitle = "Kirjautuminen" finnishMessage PleaseProvideUsername = "Käyttäjänimi puuttuu" finnishMessage PleaseProvidePassword = "Salasana puuttuu"+finnishMessage NoIdentifierProvided = "Sähköpostiosoite/käyttäjänimi puuttuu"+finnishMessage InvalidEmailAddress = "Annettu sähköpostiosoite ei kelpaa"+finnishMessage PasswordResetTitle = "Uuden salasanan tilaaminen"+finnishMessage ProvideIdentifier = "Sähköpostiosoite tai käyttäjänimi"+finnishMessage SendPasswordResetEmail = "Lähetä uusi salasana sähköpostitse"+finnishMessage PasswordResetPrompt = "Anna sähköpostiosoitteesi tai käyttäjätunnuksesi alla, niin lähetämme uuden salasanan sähköpostitse."+finnishMessage InvalidUsernamePass = "Virheellinen käyttäjänimi tai salasana."++chineseMessage :: AuthMessage -> Text+chineseMessage NoOpenID = "无效的OpenID"+chineseMessage LoginOpenID = "用OpenID登录"+chineseMessage LoginGoogle = "用Google帐户登录"+chineseMessage LoginYahoo = "用Yahoo帐户登录"+chineseMessage Email = "邮箱"+chineseMessage Password = "密码"+chineseMessage Register = "注册"+chineseMessage RegisterLong = "注册新帐户"+chineseMessage EnterEmail = "输入你的邮箱地址，你将收到一封确认邮件。"+chineseMessage ConfirmationEmailSentTitle = "确认邮件已发送"+chineseMessage (ConfirmationEmailSent email) =+ "确认邮件已发送至 " `mappend`+ email `mappend`+ "."+chineseMessage AddressVerified = "地址验证成功，请设置新密码"+chineseMessage InvalidKeyTitle = "无效的验证码"+chineseMessage InvalidKey = "对不起，验证码无效。"+chineseMessage InvalidEmailPass = "无效的邮箱/密码组合"+chineseMessage BadSetPass = "你需要登录才能设置密码"+chineseMessage SetPassTitle = "设置密码"+chineseMessage SetPass = "设置新密码"+chineseMessage NewPass = "新密码"+chineseMessage ConfirmPass = "确认"+chineseMessage PassMismatch = "密码不匹配，请重新输入"+chineseMessage PassUpdated = "密码更新成功"+chineseMessage Facebook = "用Facebook帐户登录"+chineseMessage LoginViaEmail = "用邮箱登录"+chineseMessage InvalidLogin = "登录失败"+chineseMessage NowLoggedIn = "登录成功"+chineseMessage LoginTitle = "登录"+chineseMessage PleaseProvideUsername = "请输入用户名"+chineseMessage PleaseProvidePassword = "请输入密码"+chineseMessage NoIdentifierProvided = "缺少邮箱/用户名"+chineseMessage InvalidEmailAddress = "无效的邮箱地址"+chineseMessage PasswordResetTitle = "重置密码"+chineseMessage ProvideIdentifier = "邮箱或用户名"+chineseMessage SendPasswordResetEmail = "发送密码重置邮件"+chineseMessage PasswordResetPrompt = "输入你的邮箱地址或用户名，你将收到一封密码重置邮件。"+chineseMessage InvalidUsernamePass = "无效的用户名/密码组合"
Yesod/Auth/OpenId.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-} module Yesod.Auth.OpenId ( authOpenId , forwardUrl@@ -14,15 +15,8 @@ import qualified Web.Authenticate.OpenId as OpenId import Yesod.Form-import Yesod.Handler-import Yesod.Widget (toWidget, whamlet)-import Yesod.Request+import Yesod.Core import Text.Cassius (cassius)-#if MIN_VERSION_blaze_html(0, 5, 0)-import Text.Blaze.Html (toHtml)-#else-import Text.Blaze (toHtml)-#endif import Data.Text (Text, isPrefixOf) import qualified Yesod.Auth.Message as Msg import Control.Exception.Lifted (SomeException, try)@@ -43,7 +37,7 @@ complete = PluginR "openid" ["complete"] name = "openid_identifier" login tm = do- ident <- lift newIdent+ ident <- newIdent -- FIXME this is a hack to get GHC 7.6's type checker to allow the -- code, but it shouldn't be necessary let y :: a -> [(Text, Text)] -> Text@@ -66,23 +60,21 @@ <input type="submit" value="_{Msg.LoginOpenID}"> |] dispatch "GET" ["forward"] = do- roid <- runInputGet $ iopt textField name+ roid <- lift $ runInputGet $ iopt textField name case roid of Just oid -> do render <- getUrlRender- toMaster <- getRouteToMaster- let complete' = render $ toMaster complete- master <- getYesod+ let complete' = render complete+ master <- lift getYesod eres <- lift $ try $ OpenId.getForwardUrl oid complete' Nothing extensionFields (authHttpManager master) case eres of Left err -> do setMessage $ toHtml $ show (err :: SomeException)- redirect $ toMaster LoginR+ redirect LoginR Right x -> redirect x Nothing -> do- toMaster <- getRouteToMaster- setMessageI Msg.NoOpenID- redirect $ toMaster LoginR+ lift $ setMessageI Msg.NoOpenID+ redirect LoginR dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues dispatch "GET" ["complete"] = do rr <- getRequest@@ -93,14 +85,13 @@ completeHelper idType posts dispatch _ _ = notFound -completeHelper :: YesodAuth m => IdentifierType -> [(Text, Text)] -> GHandler Auth m ()+completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master () completeHelper idType gets' = do- master <- getYesod- eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)- toMaster <- getRouteToMaster+ master <- lift getYesod+ eres <- try $ OpenId.authenticateClaimed gets' (authHttpManager master) let onFailure err = do setMessage $ toHtml $ show (err :: SomeException)- redirect $ toMaster LoginR+ redirect LoginR let onSuccess oir = do let claimed = case OpenId.oirClaimed oir of@@ -114,7 +105,7 @@ case idType of OPLocal -> OpenId.oirOpLocal oir Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir- setCreds True $ Creds "openid" i gets''+ lift $ setCreds True $ Creds "openid" i gets'' either onFailure onSuccess eres -- | The main identifier provided by the OpenID authentication plugin is the
+ Yesod/Auth/Routes.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+module Yesod.Auth.Routes where++import Yesod.Core+import Data.Text (Text)++data Auth = Auth++mkYesodSubData "Auth" [parseRoutes|+/check CheckR GET+/login LoginR GET+/logout LogoutR GET POST+/page/#Text/*Texts PluginR+|]
Yesod/Auth/Rpxnow.hs view
@@ -10,9 +10,7 @@ import qualified Web.Authenticate.Rpxnow as Rpxnow import Control.Monad (mplus) -import Yesod.Handler-import Yesod.Widget-import Yesod.Request+import Yesod.Core import Text.Hamlet (hamlet) import Data.Text (pack, unpack) import Data.Text.Encoding (encodeUtf8, decodeUtf8With)@@ -27,12 +25,8 @@ authRpxnow app apiKey = AuthPlugin "rpxnow" dispatch login where- login ::- forall sub master.- ToWidget sub master (GWidget sub master ())- => (Route Auth -> Route master) -> GWidget sub master () login tm = do- render <- lift getUrlRender+ render <- getUrlRender let queryString = decodeUtf8With lenientDecode $ renderQuery True [("token_url", Just $ encodeUtf8 $ render $ tm $ PluginR "rpxnow" [])] toWidget [hamlet|@@ -45,7 +39,7 @@ token <- case token1 ++ token2 of [] -> invalidArgs ["token: Value not supplied"] x:_ -> return $ unpack x- master <- getYesod+ master <- lift getYesod Rpxnow.Identifier ident extra <- lift $ Rpxnow.authenticate apiKey token (authHttpManager master) let creds = Creds "rpxnow" ident@@ -54,7 +48,7 @@ $ maybe id (\x -> (:) ("displayName", x)) (fmap pack $ getDisplayName $ map (unpack *** unpack) extra) []- setCreds True creds+ lift $ setCreds True creds dispatch _ _ = notFound -- | Get some form of a display name.
yesod-auth.cabal view
@@ -1,5 +1,5 @@ name: yesod-auth-version: 1.1.7+version: 1.2.0 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin@@ -10,31 +10,32 @@ cabal-version: >= 1.6.0 build-type: Simple homepage: http://www.yesodweb.com/-description: Authentication for Yesod.+description: This package provides a pluggable mechanism for allowing users to authenticate with your site. It comes with a number of common plugins, such as OpenID, BrowserID (a.k.a., Mozilla Persona), and email. Other packages are available from Hackage as well. If you've written such an add-on, please notify me so that it can be added to this description.+ .+ * <http://hackage.haskell.org/package/yesod-auth-account>: An account authentication plugin for Yesod extra-source-files: persona_sign_in_blue.png library build-depends: base >= 4 && < 5 , authenticate >= 1.3 , bytestring >= 0.9.1.4- , yesod-core >= 1.1 && < 1.2- , wai >= 1.3+ , yesod-core >= 1.2 && < 1.3+ , wai >= 1.4 , template-haskell , pureMD5 >= 2.0 , random >= 1.0.0.2 , text >= 0.7 , mime-mail >= 0.3- , yesod-persistent >= 1.1+ , yesod-persistent >= 1.2 , hamlet >= 1.1 && < 1.2 , shakespeare-css >= 1.0 && < 1.1 , shakespeare-js >= 1.0.2 && < 1.2- , yesod-json >= 1.1 && < 1.2 , containers , unordered-containers- , yesod-form >= 1.1 && < 1.3+ , yesod-form >= 1.3 && < 1.4 , transformers >= 0.2.2- , persistent >= 1.0 && < 1.2- , persistent-template >= 1.0 && < 1.2+ , persistent >= 1.2 && < 1.3+ , persistent-template >= 1.2 && < 1.3 , SHA >= 1.4.1.3 , http-conduit >= 1.5 , aeson >= 0.5@@ -45,6 +46,8 @@ , network , http-types , file-embed+ , email-validate >= 1.0+ , data-default exposed-modules: Yesod.Auth Yesod.Auth.BrowserId@@ -55,6 +58,7 @@ Yesod.Auth.HashDB Yesod.Auth.Message Yesod.Auth.GoogleEmail+ other-modules: Yesod.Auth.Routes ghc-options: -Wall source-repository head