Merged. Thanks!
On Mon, Feb 29, 2016 at 09:48:07PM +0200, fr33domlover wrote: > From: fr33domlover <[email protected]> > > --- > src/Foundation.hs | 25 ++++++++++++++++--------- > 1 file changed, 16 insertions(+), 9 deletions(-) > > diff --git a/src/Foundation.hs b/src/Foundation.hs > index 7a78f98..78797fc 100644 > --- a/src/Foundation.hs > +++ b/src/Foundation.hs > @@ -17,6 +17,7 @@ import Text.Hamlet (hamletFile) > import Text.Jasmine (minifym) > import Web.Authenticate.BrowserId (browserIdJs) > import Yesod hiding (runDB, (==.), count, Value) > +import Yesod.Auth.Message (AuthMessage (..)) > import Yesod.Auth.BrowserId (authBrowserId) > import Yesod.Auth.HashDB (authHashDB, setPassword) > import Yesod.Core.Types (Logger) > @@ -234,16 +235,22 @@ instance YesodAuth App where > -- Override the above destinations when a Referer: header is present > redirectToReferer _ = True > > - getAuthId creds = do > - maybe_user_id <- runDB $ getBy $ UniqueUser $ credsIdent creds > + authenticate creds = do > + let ident = credsIdent creds > + maybe_user_id <- runDB $ getBy $ UniqueUser ident > case (credsPlugin creds, maybe_user_id) of > - (_, Just (Entity user_id _)) -> return $ Just user_id > - ("hashdb", _) -> error "Credentials not recognized" > - ("browserid", _) -> > - createUser (credsIdent creds) Nothing Nothing emailStuff > Nothing Nothing > - _ -> error "Unhandled credentials plugin" > - where > - emailStuff = Just $ NewEmail True $ credsIdent creds > + (_, Just (Entity user_id _)) -> return $ Authenticated user_id > + ("hashdb", _) -> return $ UserError $ IdentifierNotFound ident > + ("browserid", _) -> do > + let emailStuff = Just $ NewEmail True ident > + muid <- > + createUser ident Nothing Nothing emailStuff Nothing > Nothing > + return $ case muid of > + -- The Nothing case never really runs because > 'createUser' > + -- throws an exception on failure > + Nothing -> UserError InvalidLogin > + Just user_id -> Authenticated user_id > + _ -> return $ ServerError "Unhandled credentials plugin" > > -- You can add other plugins like BrowserID, email or OAuth here > authPlugins _ = [ snowdriftAuthBrowserId, snowdriftAuthHashDB ] > -- > 1.9.1 > > _______________________________________________ > Dev mailing list > [email protected] > https://lists.snowdrift.coop/mailman/listinfo/dev
signature.asc
Description: Digital signature
_______________________________________________ Dev mailing list [email protected] https://lists.snowdrift.coop/mailman/listinfo/dev
