yesod-auth 1.2.7.1 → 1.3.0.0
raw patch · 9 files changed
+185/−417 lines, 9 filesdep −shakespearedep ~hamletdep ~shakespeare-cssdep ~shakespeare-js
Dependencies removed: shakespeare
Dependency ranges changed: hamlet, shakespeare-css, shakespeare-js
Files
- Yesod/Auth.hs +48/−35
- Yesod/Auth/BrowserId.hs +1/−1
- Yesod/Auth/Dummy.hs +1/−1
- Yesod/Auth/Email.hs +119/−87
- Yesod/Auth/GoogleEmail.hs +3/−3
- Yesod/Auth/HashDB.hs +0/−278
- Yesod/Auth/OpenId.hs +2/−2
- Yesod/Auth/Rpxnow.hs +1/−1
- yesod-auth.cabal +10/−9
Yesod/Auth.hs view
@@ -22,6 +22,7 @@ -- * Plugin interface , Creds (..) , setCreds+ , setCredsRedirect , clearCreds , loginErrorMessage , loginErrorMessageI@@ -36,6 +37,9 @@ , AuthHandler -- * Internal , credsKey+ , provideJsonMessage+ , messageJson401+ , asHtml ) where import Control.Monad (when)@@ -64,6 +68,7 @@ import Network.HTTP.Types (unauthorized401) import Control.Monad.Trans.Resource (MonadResourceBase) import qualified Control.Monad.Trans.Writer as Writer+import Control.Monad (void) type AuthRoute = Route Auth @@ -74,7 +79,7 @@ data AuthPlugin master = AuthPlugin { apName :: Text- , apDispatch :: Method -> [Piece] -> AuthHandler master ()+ , apDispatch :: Method -> [Piece] -> AuthHandler master TypedContent , apLogin :: (Route Auth -> Route master) -> WidgetT master IO () } @@ -175,9 +180,6 @@ onErrorHtml dest msg = do setMessage $ toHtml msg fmap asHtml $ redirect dest- where- asHtml :: Html -> Html- asHtml = id -- | Internal session key used to hold the authentication information. --@@ -231,7 +233,7 @@ loginErrorMessageI :: (MonadResourceBase m, YesodAuth master) => Route child -> AuthMessage- -> HandlerT child (HandlerT master m) a+ -> HandlerT child (HandlerT master m) TypedContent loginErrorMessageI dest msg = do toParent <- getRouteToParent lift $ loginErrorMessageMasterI (toParent dest) msg@@ -240,7 +242,7 @@ loginErrorMessageMasterI :: (YesodAuth master, MonadResourceBase m, RenderMessage master AuthMessage) => Route master -> AuthMessage- -> HandlerT master m a+ -> HandlerT master m TypedContent loginErrorMessageMasterI dest msg = do mr <- getMessageRender loginErrorMessage dest (mr msg)@@ -250,48 +252,56 @@ loginErrorMessage :: (YesodAuth master, MonadResourceBase m) => Route master -> Text- -> HandlerT master m a-loginErrorMessage dest msg =- sendResponseStatus unauthorized401 =<< (- selectRep $ do- provideRep $ do- onErrorHtml dest msg- provideJsonMessage msg- )+ -> HandlerT master m TypedContent+loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg) +messageJson401 :: MonadResourceBase m => Text -> HandlerT master m Html -> HandlerT master m TypedContent+messageJson401 msg html = selectRep $ do+ provideRep html+ provideRep $ do+ let obj = object ["message" .= msg]+ void $ sendResponseStatus unauthorized401 obj+ return obj+ provideJsonMessage :: Monad m => Text -> Writer.Writer (Endo [ProvidedRep m]) () provideJsonMessage msg = provideRep $ return $ object ["message" .= msg] --- | 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- -> HandlerT master IO ()-setCreds doRedirects creds = do+setCredsRedirect :: YesodAuth master+ => Creds master -- ^ new credentials+ -> HandlerT master IO TypedContent+setCredsRedirect creds = do y <- getYesod maid <- getAuthId creds case maid of- Nothing -> when doRedirects $ do+ Nothing -> case authRoute y of Nothing -> do- sendResponseStatus unauthorized401 =<< (- selectRep $ do- provideRep $ authLayout $ toWidget [shamlet|<h1>Invalid login|]- provideJsonMessage "Invalid Login"- )+ messageJson401 "Invalid Login" $ authLayout $+ toWidget [shamlet|<h1>Invalid login|] Just ar -> loginErrorMessageMasterI ar Msg.InvalidLogin Just aid -> do setSession credsKey $ toPathPiece aid- when doRedirects $ do- onLogin- res <- selectRep $ do- provideRepType typeHtml $ do- _ <- redirectUltDest $ loginDest y- return ()- provideJsonMessage "Login Successful"- sendResponse res+ onLogin+ res <- selectRep $ do+ provideRepType typeHtml $+ fmap asHtml $ redirectUltDest $ loginDest y+ provideJsonMessage "Login Successful"+ sendResponse res +-- | 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+ -> HandlerT master IO ()+setCreds doRedirects creds =+ if doRedirects+ then void $ setCredsRedirect creds+ else do maid <- getAuthId creds+ case maid of+ Nothing -> return ()+ Just aid -> setSession credsKey $ toPathPiece aid+ -- | same as defaultLayoutJson, but uses authLayout authLayoutJson :: (YesodAuth site, ToJSON j) => WidgetT site IO () -- ^ HTML@@ -349,7 +359,7 @@ postLogoutR :: AuthHandler master () postLogoutR = lift $ clearCreds True -handlePluginR :: Text -> [Text] -> AuthHandler master ()+handlePluginR :: Text -> [Text] -> AuthHandler master TypedContent handlePluginR plugin pieces = do master <- lift getYesod env <- waiRequest@@ -436,3 +446,6 @@ instance YesodAuth master => YesodSubDispatch Auth (HandlerT master IO) where yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth)++asHtml :: Html -> Html+asHtml = id
Yesod/Auth/BrowserId.hs view
@@ -77,7 +77,7 @@ $logErrorS "yesod-auth" "BrowserID assertion failure" tm <- getRouteToParent lift $ loginErrorMessage (tm LoginR) "BrowserID login error."- Just email -> lift $ setCreds True Creds+ Just email -> lift $ setCredsRedirect Creds { credsPlugin = pid , credsIdent = email , credsExtra = []
Yesod/Auth/Dummy.hs view
@@ -18,7 +18,7 @@ where dispatch "POST" [] = do ident <- lift $ runInputPost $ ireq textField "ident"- lift $ setCreds True $ Creds "dummy" ident []+ lift $ setCredsRedirect $ Creds "dummy" ident [] dispatch _ _ = notFound url = PluginR "dummy" [] login authToMaster =
Yesod/Auth/Email.hs view
@@ -46,8 +46,8 @@ import qualified Text.Email.Validate import qualified Yesod.Auth.Message as Msg import Control.Applicative ((<$>), (<*>))+import Control.Monad (void) import Yesod.Form-import Control.Monad (when) import Data.Time (getCurrentTime, addUTCTime) import Safe (readMay) @@ -83,7 +83,11 @@ , emailCredsEmail :: Email } -class (YesodAuth site, PathPiece (AuthEmailId site)) => YesodAuthEmail site where+class ( YesodAuth site+ , PathPiece (AuthEmailId site)+ , (RenderMessage site Msg.AuthMessage)+ )+ => YesodAuthEmail site where type AuthEmailId site -- | Add a new email address to the database, but indicate that the address@@ -172,10 +176,14 @@ -- | Response after sending a confirmation email. -- -- Since 1.2.2- confirmationEmailSentResponse :: Text -> HandlerT site IO Html- confirmationEmailSentResponse identifier = authLayout $ do- setTitleI Msg.ConfirmationEmailSentTitle- [whamlet|<p>_{Msg.ConfirmationEmailSent identifier}|]+ confirmationEmailSentResponse :: Text -> HandlerT site IO TypedContent+ confirmationEmailSentResponse identifier = do+ mr <- getMessageRender+ messageJson401 (mr msg) $ authLayout $ do+ setTitleI Msg.ConfirmationEmailSentTitle+ [whamlet|<p>_{msg}|]+ where+ msg = Msg.ConfirmationEmailSent identifier -- | Additional normalization of email addresses, besides standard canonicalization. --@@ -218,7 +226,7 @@ -- field for the old password should be presented. -- Otherwise, just two fields for the new password are -- needed.- -> AuthHandler site Html+ -> AuthHandler site TypedContent setPasswordHandler = defaultSetPasswordHandler @@ -280,40 +288,46 @@ registerHelper :: YesodAuthEmail master => Bool -- ^ allow usernames? -> Route Auth- -> HandlerT Auth (HandlerT master IO) Html+ -> HandlerT Auth (HandlerT master IO) TypedContent registerHelper allowUsername dest = do y <- lift getYesod midentifier <- lookupPostParam "email"- identifier <-- case midentifier of- Nothing -> loginErrorMessageI dest Msg.NoIdentifierProvided+ let eidentifier = case midentifier of+ Nothing -> Left Msg.NoIdentifierProvided Just x | Just x' <- Text.Email.Validate.canonicalizeEmail (encodeUtf8 x) ->- return $ normalizeEmailAddress y $ decodeUtf8With lenientDecode x'- | allowUsername -> return $ TS.strip x- | otherwise -> loginErrorMessageI dest Msg.InvalidEmailAddress+ Right $ normalizeEmailAddress y $ decodeUtf8With lenientDecode x'+ | allowUsername -> Right $ TS.strip x+ | otherwise -> Left Msg.InvalidEmailAddress - 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- lift $ setVerifyKey lid key- return (lid, key, email)- Nothing- | allowUsername ->- loginErrorMessageI dest (Msg.IdentifierNotFound identifier)- | otherwise -> do- key <- liftIO $ randomKey y- lid <- lift $ addUnverified identifier key- return (lid, key, identifier)- render <- getUrlRender- let verUrl = render $ verify (toPathPiece lid) verKey- lift $ sendVerifyEmail email verKey verUrl- lift $ confirmationEmailSentResponse identifier+ case eidentifier of+ Left route -> loginErrorMessageI dest route+ Right identifier -> do -postRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html+ mecreds <- lift $ getEmailCreds identifier+ registerCreds <-+ case mecreds of+ Just (EmailCreds lid _ _ (Just key) email) -> return $ Just (lid, key, email)+ Just (EmailCreds lid _ _ Nothing email) -> do+ key <- liftIO $ randomKey y+ lift $ setVerifyKey lid key+ return $ Just (lid, key, email)+ Nothing+ | allowUsername -> return Nothing+ | otherwise -> do+ key <- liftIO $ randomKey y+ lid <- lift $ addUnverified identifier key+ return $ Just (lid, key, identifier)++ case registerCreds of+ Nothing -> loginErrorMessageI dest (Msg.IdentifierNotFound identifier)+ Just (lid, verKey, email) -> do+ render <- getUrlRender+ let verUrl = render $ verify (toPathPiece lid) verKey+ lift $ sendVerifyEmail email verKey verUrl+ lift $ confirmationEmailSentResponse identifier++postRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent postRegisterR = registerHelper False registerR getForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html@@ -337,35 +351,43 @@ <button .btn>_{Msg.SendPasswordResetEmail} |] -postForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html+postForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent postForgotPasswordR = registerHelper True forgotPasswordR getVerifyR :: YesodAuthEmail site => AuthEmailId site -> Text- -> HandlerT Auth (HandlerT site IO) Html+ -> HandlerT Auth (HandlerT site IO) TypedContent getVerifyR lid key = do realKey <- lift $ getVerifyKey lid memail <- lift $ getEmail lid+ mr <- lift getMessageRender case (realKey == Just key, memail) of (True, Just email) -> do muid <- lift $ verifyAccount lid case muid of- Nothing -> return ()+ Nothing -> invalidKey mr Just uid -> do lift $ setCreds False $ Creds "email-verify" email [("verifiedEmail", email)] -- FIXME uid?- lift $ setMessageI Msg.AddressVerified lift $ setLoginLinkKey uid- redirect setpassR- _ -> return ()- lift $ authLayout $ do- setTitleI Msg.InvalidKey+ let msgAv = Msg.AddressVerified+ selectRep $ do+ provideRep $ do+ lift $ setMessageI msgAv+ fmap asHtml $ redirect setpassR+ provideJsonMessage $ mr msgAv+ _ -> invalidKey mr+ where+ msgIk = Msg.InvalidKey+ invalidKey mr = messageJson401 (mr msgIk) $ lift $ authLayout $ do+ setTitleI msgIk [whamlet| $newline never-<p>_{Msg.InvalidKey}+<p>_{msgIk} |] -postLoginR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) ()++postLoginR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent postLoginR = do (identifier, pass) <- lift $ runInputPost $ (,) <$> ireq textField "email"@@ -388,37 +410,40 @@ let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier case maid of Just email ->- lift $ setCreds True $ Creds+ lift $ setCredsRedirect $ Creds (if isEmail then "email" else "username") email [("verifiedEmail", email)]- Nothing -> do+ Nothing -> loginErrorMessageI LoginR $ if isEmail then Msg.InvalidEmailPass else Msg.InvalidUsernamePass -getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html+getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent getPasswordR = do maid <- lift maybeAuthId case maid of- Just _ -> return () Nothing -> loginErrorMessageI LoginR Msg.BadSetPass- needOld <- maybe (return True) (lift . needOldPassword) maid- setPasswordHandler needOld+ Just _ -> do+ needOld <- maybe (return True) (lift . needOldPassword) maid+ setPasswordHandler needOld -- | Default implementation of 'setPasswordHandler'. -- -- Since: 1.2.6-defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> AuthHandler master Html+defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> AuthHandler master TypedContent defaultSetPasswordHandler needOld = do tp <- getRouteToParent pass0 <- newIdent pass1 <- newIdent pass2 <- newIdent- lift $ authLayout $ do- setTitleI Msg.SetPassTitle- [whamlet|+ mr <- lift getMessageRender+ selectRep $ do+ provideJsonMessage $ mr Msg.SetPass+ provideRep $ lift $ authLayout $ do+ setTitleI Msg.SetPassTitle+ [whamlet| $newline never <h3>_{Msg.SetPass} <form method="post" action="@{tp setpassR}">@@ -444,45 +469,52 @@ <input type="submit" value=_{Msg.SetPassTitle}> |] -postPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) ()+postPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent postPasswordR = do maid <- lift maybeAuthId- aid <- case maid of- Nothing -> loginErrorMessageI LoginR Msg.BadSetPass- Just aid -> return aid-- tm <- getRouteToParent+ case maid of+ Nothing -> loginErrorMessageI LoginR Msg.BadSetPass+ Just aid -> do+ tm <- getRouteToParent - needOld <- lift $ needOldPassword aid- when needOld $ do- current <- lift $ runInputPost $ ireq textField "current"- mrealpass <- lift $ getPassword aid- case mrealpass of- Nothing ->- lift $ loginErrorMessage (tm setpassR) "You do not currently have a password set on your account"- Just realpass- | isValidPass current realpass -> return ()- | otherwise ->- lift $ loginErrorMessage (tm setpassR) "Invalid current password, please try again"+ needOld <- lift $ needOldPassword aid+ if not needOld then confirmPassword aid tm else do+ current <- lift $ runInputPost $ ireq textField "current"+ mrealpass <- lift $ getPassword aid+ case mrealpass of+ Nothing ->+ lift $ loginErrorMessage (tm setpassR) "You do not currently have a password set on your account"+ Just realpass+ | isValidPass current realpass -> confirmPassword aid tm+ | otherwise ->+ lift $ loginErrorMessage (tm setpassR) "Invalid current password, please try again" - (new, confirm) <- lift $ runInputPost $ (,)- <$> ireq textField "new"- <*> ireq textField "confirm"- when (new /= confirm) $- loginErrorMessageI setpassR Msg.PassMismatch+ where+ msgOk = Msg.PassUpdated+ confirmPassword aid tm = do+ (new, confirm) <- lift $ runInputPost $ (,)+ <$> ireq textField "new"+ <*> ireq textField "confirm" - isSecure <- lift $ checkPasswordSecurity aid new- case isSecure of- Left e -> lift $ loginErrorMessage (tm setpassR) e- Right () -> return ()+ if new /= confirm+ then loginErrorMessageI setpassR Msg.PassMismatch+ else do+ isSecure <- lift $ checkPasswordSecurity aid new+ case isSecure of+ Left e -> lift $ loginErrorMessage (tm setpassR) e+ Right () -> do+ salted <- liftIO $ saltPass new+ y <- lift $ do+ setPassword aid salted+ deleteSession loginLinkKey+ setMessageI msgOk+ getYesod - salted <- liftIO $ saltPass new- lift $ do- y <- getYesod- setPassword aid salted- setMessageI Msg.PassUpdated- deleteSession loginLinkKey- redirect $ afterPasswordRoute y+ mr <- lift getMessageRender+ selectRep $ do+ provideRep $+ fmap asHtml $ lift $ redirect $ afterPasswordRoute y+ provideJsonMessage (mr msgOk) saltLength :: Int saltLength = 5
Yesod/Auth/GoogleEmail.hs view
@@ -69,19 +69,19 @@ completeHelper posts dispatch _ _ = notFound -completeHelper :: YesodAuth master => [(Text, Text)] -> AuthHandler master ()+completeHelper :: YesodAuth master => [(Text, Text)] -> AuthHandler master TypedContent completeHelper gets' = do master <- lift getYesod eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master) tm <- getRouteToParent either (onFailure tm) (onSuccess tm) eres where- onFailure tm err = do+ onFailure tm err = lift $ loginErrorMessage (tm LoginR) $ T.pack $ show (err :: SomeException) onSuccess tm 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) -> lift $ setCreds True $ Creds pid email []+ (Just email, True) -> lift $ setCredsRedirect $ Creds pid email [] (_, False) -> lift $ loginErrorMessage (tm LoginR) "Only Google login is supported" (Nothing, _) -> lift $ loginErrorMessage (tm LoginR) "No email address provided"
− Yesod/Auth/HashDB.hs
@@ -1,278 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE CPP #-}----------------------------------------------------------------------------------- |--- Module : Yesod.Auth.HashDB--- Copyright : (c) Patrick Brisbin 2010 --- License : as-is------ Maintainer : pbrisbin@gmail.com--- Stability : Stable--- Portability : Portable------ /WARNING/: This module was /not/ designed with security in mind, and is not--- suitable for production sites. In the near future, it will likely be either--- deprecated or rewritten to have a more secure implementation. For more--- information, see: <https://github.com/yesodweb/yesod/issues/668>.------ A yesod-auth AuthPlugin designed to look users up in Persist where--- their user id's and a salted SHA1 hash of their password is stored.------ Example usage:------ > -- import the function--- > import Auth.HashDB--- >--- > -- make sure you have an auth route--- > mkYesodData "MyApp" [$parseRoutes|--- > / RootR GET--- > /auth AuthR Auth getAuth--- > |]--- >--- >--- > -- make your app an instance of YesodAuth using this plugin--- > instance YesodAuth MyApp where--- > type AuthId MyApp = UserId--- >--- > loginDest _ = RootR--- > logoutDest _ = RootR--- > getAuthId = getAuthIdHashDB AuthR (Just . UniqueUser)--- > authPlugins = [authHashDB (Just . UniqueUser)]--- >--- >--- > -- include the migration function in site startup--- > withServer :: (Application -> IO a) -> IO a--- > withServer f = withConnectionPool $ \p -> do--- > runSqlPool (runMigration migrateUsers) p--- > let h = DevSite p------ Note that function which converts username to unique identifier must be same.------ Your app must be an instance of YesodPersist. and the username,--- salt and hashed-passwords should be added to the database.------ > echo -n 'MySaltMyPassword' | sha1sum------ can be used to get the hash from the commandline.------------------------------------------------------------------------------------module Yesod.Auth.HashDB- ( HashDBUser(..)- , Unique (..)- , setPassword- -- * Authentification- , validateUser- , authHashDB- , getAuthIdHashDB- -- * Predefined data type- , User- , UserGeneric (..)- , UserId- , EntityField (..)- , migrateUsers- ) where--import Yesod.Persist-import Yesod.Form-import Yesod.Auth-import Yesod.Core-import Text.Hamlet (hamlet)--import Control.Applicative ((<$>), (<*>))-import Control.Monad (replicateM,liftM)-import Data.Typeable--import qualified Data.ByteString.Lazy.Char8 as BS (pack)-import Data.Digest.Pure.SHA (sha1, showDigest)-import Data.Text (Text, pack, unpack, append)-import Data.Maybe (fromMaybe)-import System.Random (randomRIO)--- | Interface for data type which holds user info. It's just a--- collection of getters and setters-class HashDBUser user where- -- | Retrieve password hash from user data- userPasswordHash :: user -> Maybe Text- -- | Retrieve salt for password- userPasswordSalt :: user -> Maybe Text-- -- | Deprecated for the better named setSaltAndPasswordHash - setUserHashAndSalt :: Text -- ^ Salt- -> Text -- ^ Password hash- -> user -> user- setUserHashAndSalt = setSaltAndPasswordHash-- -- | a callback for setPassword- setSaltAndPasswordHash :: Text -- ^ Salt- -> Text -- ^ Password hash- -> user -> user- setSaltAndPasswordHash = setUserHashAndSalt---- | Generate random salt. Length of 8 is chosen arbitrarily-randomSalt :: MonadIO m => m Text-randomSalt = pack `liftM` liftIO (replicateM 8 (randomRIO ('0','z')))---- | Calculate salted hash using SHA1.-saltedHash :: Text -- ^ Salt- -> Text -- ^ Password- -> Text-saltedHash salt = - pack . showDigest . sha1 . BS.pack . unpack . append salt---- | Set password for user. This function should be used for setting--- passwords. It generates random salt and calculates proper hashes.-setPassword :: (MonadIO m, HashDBUser user) => Text -> user -> m user-setPassword pwd u = do salt <- randomSalt- return $ setSaltAndPasswordHash salt (saltedHash salt pwd) u---------------------------------------------------------------------- Authentification--------------------------------------------------------------------- | Given a user ID and password in plaintext, validate them against--- the database values.-validateUser :: ( YesodPersist yesod- , b ~ YesodPersistBackend yesod- , PersistMonadBackend (b (HandlerT yesod IO)) ~ PersistEntityBackend user- , PersistUnique (b (HandlerT yesod IO))- , PersistEntity user- , HashDBUser user- ) => - Unique user -- ^ User unique identifier- -> Text -- ^ Password in plaint-text- -> HandlerT yesod IO Bool-validateUser userID passwd = do- -- Checks that hash and password match- let validate u = do hash <- userPasswordHash u- salt <- userPasswordSalt u- return $ hash == saltedHash salt passwd- -- Get user data- user <- runDB $ getBy userID- return $ fromMaybe False $ validate . entityVal =<< user---login :: AuthRoute-login = PluginR "hashdb" ["login"]----- | Handle the login form. First parameter is function which maps--- username (whatever it might be) to unique user ID.-postLoginR :: ( YesodAuth y, YesodPersist y- , HashDBUser user, PersistEntity user- , b ~ YesodPersistBackend y- , PersistMonadBackend (b (HandlerT y IO)) ~ PersistEntityBackend user- , PersistUnique (b (HandlerT y IO))- )- => (Text -> Maybe (Unique user))- -> HandlerT Auth (HandlerT y IO) ()-postLoginR uniq = do- (mu,mp) <- lift $ runInputPost $ (,)- <$> iopt textField "username"- <*> iopt textField "password"-- isValid <- lift $ fromMaybe (return False) - (validateUser <$> (uniq =<< mu) <*> mp)- if isValid - then lift $ setCreds True $ Creds "hashdb" (fromMaybe "" mu) []- else do- tm <- getRouteToParent- lift $ loginErrorMessage (tm LoginR) "Invalid username/password"----- | 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- , Key user ~ AuthId master- , b ~ YesodPersistBackend master- , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend user- , PersistUnique (b (HandlerT master IO))- )- => (AuthRoute -> Route master) -- ^ your site's Auth Route- -> (Text -> Maybe (Unique user)) -- ^ gets user ID- -> Creds master -- ^ the creds argument- -> HandlerT master IO (Maybe (AuthId master))-getAuthIdHashDB authR uniq creds = do- muid <- maybeAuthId- case muid of- -- user already authenticated- Just uid -> return $ Just uid- Nothing -> do- x <- case uniq (credsIdent creds) of- Nothing -> return Nothing- Just u -> runDB (getBy u)- case x of- -- user exists- Just (Entity uid _) -> return $ Just uid- Nothing -> loginErrorMessage (authR LoginR) "User not found"---- | Prompt for username and password, validate that against a database--- which holds the username and a hash of the password-authHashDB :: ( YesodAuth m, YesodPersist m- , HashDBUser user- , PersistEntity user- , b ~ YesodPersistBackend m- , PersistMonadBackend (b (HandlerT m IO)) ~ PersistEntityBackend user- , PersistUnique (b (HandlerT m IO)))- => (Text -> Maybe (Unique user)) -> AuthPlugin m-authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> toWidget [hamlet|-$newline never- <div id="header">- <h1>Login-- <div id="login">- <form method="post" action="@{tm login}">- <table>- <tr>- <th>Username:- <td>- <input id="x" name="username" autofocus="" required>- <tr>- <th>Password:- <td>- <input type="password" name="password" required>- <tr>- <td> - <td>- <input type="submit" value="Login">-- <script>- if (!("autofocus" in document.createElement("input"))) {- document.getElementById("x").focus();- }--|]- where- dispatch "POST" ["login"] = postLoginR uniq >>= sendResponse- dispatch _ _ = notFound---------------------------------------------------------------------- Predefined datatype--------------------------------------------------------------------- | Generate data base instances for a valid user-share [mkPersist sqlSettings, mkMigrate "migrateUsers"]- [persistUpperCase|-User- username Text Eq- password Text- salt Text- UniqueUser username- deriving Typeable-|]--instance HashDBUser (UserGeneric backend) where- userPasswordHash = Just . userPassword- userPasswordSalt = Just . userSalt- setSaltAndPasswordHash s h u = u { userSalt = s- , userPassword = h- }
Yesod/Auth/OpenId.hs view
@@ -85,7 +85,7 @@ completeHelper idType posts dispatch _ _ = notFound -completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master ()+completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent completeHelper idType gets' = do master <- lift getYesod eres <- try $ OpenId.authenticateClaimed gets' (authHttpManager master)@@ -108,7 +108,7 @@ case idType of OPLocal -> OpenId.oirOpLocal oir Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir- lift $ setCreds True $ Creds "openid" i gets''+ lift $ setCredsRedirect $ Creds "openid" i gets'' -- | The main identifier provided by the OpenID authentication plugin is the -- \"OP-local identifier\". There is also sometimes a \"claimed\" identifier
Yesod/Auth/Rpxnow.hs view
@@ -48,7 +48,7 @@ $ maybe id (\x -> (:) ("displayName", x)) (fmap pack $ getDisplayName $ map (unpack *** unpack) extra) []- lift $ setCreds True creds+ lift $ setCredsRedirect creds dispatch _ _ = notFound -- | Get some form of a display name.
yesod-auth.cabal view
@@ -1,5 +1,5 @@ name: yesod-auth-version: 1.2.7.1+version: 1.3.0.0 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin@@ -10,9 +10,12 @@ cabal-version: >= 1.6.0 build-type: Simple homepage: http://www.yesodweb.com/-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+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+ .+ * <https://github.com/ollieh/yesod-auth-bcrypt/>: A replacement for the previously provided HashDB module, which has been removed. extra-source-files: persona_sign_in_blue.png library@@ -27,10 +30,9 @@ , text >= 0.7 , mime-mail >= 0.3 , yesod-persistent >= 1.2- , hamlet >= 1.1- , shakespeare- , shakespeare-css >= 1.0- , shakespeare-js >= 1.0.2+ , hamlet >= 1.1 && < 1.2+ , shakespeare-css >= 1.0 && < 1.1+ , shakespeare-js >= 1.0.2 && < 1.3 , containers , unordered-containers , yesod-form >= 1.3 && < 1.4@@ -59,7 +61,6 @@ Yesod.Auth.Email Yesod.Auth.OpenId Yesod.Auth.Rpxnow- Yesod.Auth.HashDB Yesod.Auth.Message Yesod.Auth.GoogleEmail other-modules: Yesod.Auth.Routes