yesod-auth 1.2.0 → 1.2.0.1
raw patch · 7 files changed
+107/−87 lines, 7 filesdep +resourcet
Dependencies added: resourcet
Files
- Yesod/Auth.hs +53/−14
- Yesod/Auth/BrowserId.hs +3/−2
- Yesod/Auth/Email.hs +7/−15
- Yesod/Auth/GoogleEmail.hs +13/−21
- Yesod/Auth/HashDB.hs +3/−6
- Yesod/Auth/OpenId.hs +26/−28
- yesod-auth.cabal +2/−1
Yesod/Auth.hs view
@@ -23,6 +23,8 @@ , Creds (..) , setCreds , clearCreds+ , loginErrorMessage+ , loginErrorMessageI -- * User functions , defaultMaybeAuthId , maybeAuth@@ -44,6 +46,7 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.HashMap.Lazy as Map+import Data.Monoid (Endo) import Network.HTTP.Conduit (Manager) import qualified Network.Wai as W@@ -56,6 +59,9 @@ import Yesod.Form (FormMessage) import Data.Typeable (Typeable) import Control.Exception (Exception)+import Network.HTTP.Types (unauthorized401)+import Control.Monad.Trans.Resource (MonadResourceBase)+import qualified Control.Monad.Trans.Writer as Writer type AuthRoute = Route Auth @@ -202,6 +208,46 @@ $ get aid return $ Entity aid a ++loginErrorMessageI :: (MonadResourceBase m, YesodAuth master)+ => Route child+ -> AuthMessage+ -> HandlerT child (HandlerT master m) a+loginErrorMessageI dest msg = do+ toParent <- getRouteToParent+ lift $ loginErrorMessageMasterI (toParent dest) msg+++loginErrorMessageMasterI :: (YesodAuth master, MonadResourceBase m, RenderMessage master AuthMessage)+ => Route master+ -> AuthMessage+ -> HandlerT master m a+loginErrorMessageMasterI dest msg = do+ mr <- getMessageRender+ loginErrorMessage dest (mr msg)++-- | For HTML, set the message and redirect to the route.+-- For JSON, send the message and a 401 status+loginErrorMessage :: MonadResourceBase m+ => Route site+ -> Text+ -> HandlerT site m a+loginErrorMessage dest msg =+ sendResponseStatus unauthorized401 =<< (+ selectRep $ do+ provideRep $ do+ setMessage $ toHtml msg+ fmap asHtml $ redirect dest+ provideJsonMessage msg+ )+ where+ asHtml :: Html -> Html+ asHtml = id++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@@ -214,18 +260,12 @@ Nothing -> when doRedirects $ do case authRoute y of Nothing -> do- res <- selectRep $ do+ sendResponseStatus unauthorized401 =<< (+ 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+ provideJsonMessage "Invalid Login"+ )+ Just ar -> loginErrorMessageMasterI ar Msg.InvalidLogin Just aid -> do setSession credsKey $ toPathPiece aid when doRedirects $ do@@ -234,7 +274,7 @@ provideRepType typeHtml $ do _ <- redirectUltDest $ loginDest y return ()- provideRep $ return $ object ["message" .= ("Login Successful" :: Text)]+ provideJsonMessage "Login Successful" sendResponse res -- | Clears current user credentials for the session.@@ -357,8 +397,7 @@ instance YesodAuth master => RenderMessage master AuthMessage where renderMessage = renderAuthMessage -data AuthException = InvalidBrowserIDAssertion- | InvalidFacebookResponse+data AuthException = InvalidFacebookResponse deriving (Show, Typeable) instance Exception AuthException
Yesod/Auth/BrowserId.hs view
@@ -19,7 +19,6 @@ import qualified Data.Text as T import Data.Maybe (fromMaybe) import Control.Monad (when, unless)-import Control.Exception (throwIO) import Text.Julius (julius, rawJS) import Network.URI (uriPath, parseURI) import Data.FileEmbed (embedFile)@@ -74,7 +73,9 @@ return $ T.takeWhile (/= '/') $ stripScheme $ r LoginR memail <- lift $ checkAssertion audience assertion (authHttpManager master) case memail of- Nothing -> liftIO $ throwIO InvalidBrowserIDAssertion+ Nothing -> do+ $logErrorS "yesod-auth" "BrowserID assertion failure"+ loginErrorMessage LoginR "BrowserID login error." Just email -> lift $ setCreds True Creds { credsPlugin = pid , credsIdent = email
Yesod/Auth/Email.hs view
@@ -195,15 +195,13 @@ identifier <- case midentifier of Nothing -> do- lift $ setMessageI Msg.NoIdentifierProvided- redirect dest+ loginErrorMessageI dest Msg.NoIdentifierProvided 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+ loginErrorMessageI dest Msg.InvalidEmailAddress mecreds <- lift $ getEmailCreds identifier (lid, verKey, email) <- case mecreds of@@ -298,11 +296,10 @@ email [("verifiedEmail", email)] Nothing -> do- lift $ setMessageI $+ loginErrorMessageI LoginR $ if isEmail then Msg.InvalidEmailPass else Msg.InvalidUsernamePass- redirect LoginR getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html getPasswordR = do@@ -311,9 +308,7 @@ pass2 <- newIdent case maid of Just _ -> return ()- Nothing -> do- lift $ setMessageI Msg.BadSetPass- redirect LoginR+ Nothing -> loginErrorMessageI LoginR Msg.BadSetPass tp <- getRouteToParent lift $ defaultLayout $ do setTitleI Msg.SetPassTitle@@ -342,14 +337,11 @@ (new, confirm) <- lift $ runInputPost $ (,) <$> ireq textField "new" <*> ireq textField "confirm"- when (new /= confirm) $ do- lift $ setMessageI Msg.PassMismatch- redirect setpassR+ when (new /= confirm) $+ loginErrorMessageI setpassR Msg.PassMismatch maid <- lift maybeAuthId aid <- case maid of- Nothing -> do- lift $ setMessageI Msg.BadSetPass- redirect LoginR+ Nothing -> loginErrorMessageI LoginR Msg.BadSetPass Just aid -> return aid salted <- liftIO $ saltPass new lift $ do
Yesod/Auth/GoogleEmail.hs view
@@ -54,10 +54,7 @@ , ("openid.ui.icon", "true") ] (authHttpManager master) either- (\err -> do- setMessage $ toHtml $ show (err :: SomeException)- redirect LoginR- )+ (\err -> loginErrorMessage LoginR $ T.pack $ show (err :: SomeException)) redirect eres dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues@@ -72,20 +69,15 @@ completeHelper :: YesodAuth master => [(Text, Text)] -> AuthHandler master () completeHelper gets' = do- master <- lift getYesod- eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)- let onFailure err = do- setMessage $ toHtml $ show (err :: SomeException)- 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) -> lift $ setCreds True $ Creds pid email []- (_, False) -> do- setMessage "Only Google login is supported"- redirect LoginR- (Nothing, _) -> do- setMessage "No email address provided"- redirect LoginR- either onFailure onSuccess eres+ master <- lift getYesod+ eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)+ either onFailure onSuccess eres+ where+ onFailure err = loginErrorMessage LoginR $ T.pack $ show (err :: SomeException)+ 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) -> lift $ setCreds True $ Creds pid email []+ (_, False) -> loginErrorMessage LoginR "Only Google login is supported"+ (Nothing, _) -> loginErrorMessage LoginR "No email address provided"
Yesod/Auth/HashDB.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -87,7 +88,6 @@ 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@@ -175,8 +175,7 @@ (validateUser <$> (uniq =<< mu) <*> mp) if isValid then lift $ setCreds True $ Creds "hashdb" (fromMaybe "" mu) []- else do setMessage "Invalid username/password"- redirect LoginR+ else loginErrorMessage LoginR "Invalid username/password" -- | A drop in for the getAuthId method of your YesodAuth instance which@@ -204,9 +203,7 @@ case x of -- user exists Just (Entity uid _) -> return $ Just uid- Nothing -> do- setMessage "User not found"- redirect $ authR LoginR+ 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
Yesod/Auth/OpenId.hs view
@@ -21,16 +21,17 @@ import qualified Yesod.Auth.Message as Msg import Control.Exception.Lifted (SomeException, try) import Data.Maybe (fromMaybe)+import qualified Data.Text as T forwardUrl :: AuthRoute forwardUrl = PluginR "openid" ["forward"] data IdentifierType = Claimed | OPLocal -authOpenId :: YesodAuth m+authOpenId :: YesodAuth master => IdentifierType -> [(Text, Text)] -- ^ extension fields- -> AuthPlugin m+ -> AuthPlugin master authOpenId idType extensionFields = AuthPlugin "openid" dispatch login where@@ -68,13 +69,10 @@ 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 LoginR+ Left err -> loginErrorMessage LoginR $ T.pack $+ show (err :: SomeException) Right x -> redirect x- Nothing -> do- lift $ setMessageI Msg.NoOpenID- redirect LoginR+ Nothing -> loginErrorMessageI LoginR Msg.NoOpenID dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues dispatch "GET" ["complete"] = do rr <- getRequest@@ -87,26 +85,26 @@ completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master () completeHelper idType gets' = do- master <- lift getYesod- eres <- try $ OpenId.authenticateClaimed gets' (authHttpManager master)- let onFailure err = do- setMessage $ toHtml $ show (err :: SomeException)- redirect LoginR- let onSuccess oir = do- let claimed =- case OpenId.oirClaimed oir of- Nothing -> id- Just (OpenId.Identifier i') -> ((claimedKey, i'):)- oplocal =- case OpenId.oirOpLocal oir of- OpenId.Identifier i' -> ((opLocalKey, i'):)- gets'' = oplocal $ claimed $ filter (\(k, _) -> not $ "__" `isPrefixOf` k) gets'- i = OpenId.identifier $- case idType of- OPLocal -> OpenId.oirOpLocal oir- Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir- lift $ setCreds True $ Creds "openid" i gets''- either onFailure onSuccess eres+ master <- lift getYesod+ eres <- try $ OpenId.authenticateClaimed gets' (authHttpManager master)+ either onFailure onSuccess eres+ where+ onFailure err = loginErrorMessage LoginR $ T.pack $+ show (err :: SomeException)+ onSuccess oir = do+ let claimed =+ case OpenId.oirClaimed oir of+ Nothing -> id+ Just (OpenId.Identifier i') -> ((claimedKey, i'):)+ oplocal =+ case OpenId.oirOpLocal oir of+ OpenId.Identifier i' -> ((opLocalKey, i'):)+ gets'' = oplocal $ claimed $ filter (\(k, _) -> not $ "__" `isPrefixOf` k) gets'+ i = OpenId.identifier $+ case idType of+ OPLocal -> OpenId.oirOpLocal oir+ Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir+ lift $ setCreds True $ 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.cabal view
@@ -1,5 +1,5 @@ name: yesod-auth-version: 1.2.0+version: 1.2.0.1 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin@@ -48,6 +48,7 @@ , file-embed , email-validate >= 1.0 , data-default+ , resourcet exposed-modules: Yesod.Auth Yesod.Auth.BrowserId