yesod-auth 1.2.5.1 → 1.2.5.2
raw patch · 7 files changed
+47/−26 lines, 7 filesdep ~persistentdep ~persistent-template
Dependency ranges changed: persistent, persistent-template
Files
- Yesod/Auth.hs +14/−8
- Yesod/Auth/BrowserId.hs +2/−1
- Yesod/Auth/Email.hs +7/−3
- Yesod/Auth/GoogleEmail.hs +10/−6
- Yesod/Auth/HashDB.hs +3/−1
- Yesod/Auth/OpenId.hs +8/−4
- yesod-auth.cabal +3/−3
Yesod/Auth.hs view
@@ -165,6 +165,16 @@ => HandlerT master IO (Maybe (AuthId master)) maybeAuthId = defaultMaybeAuthId + -- | Called on login error for HTTP requests. By default, calls+ -- @setMessage@ and redirects to @dest@.+ onErrorHtml :: (MonadResourceBase m) => Route master -> Text -> HandlerT master m Html+ 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. -- -- Since 1.2.3@@ -233,21 +243,17 @@ -- | For HTML, set the message and redirect to the route. -- For JSON, send the message and a 401 status-loginErrorMessage :: MonadResourceBase m- => Route site+loginErrorMessage :: (YesodAuth master, MonadResourceBase m)+ => Route master -> Text- -> HandlerT site m a+ -> HandlerT master m a loginErrorMessage dest msg = sendResponseStatus unauthorized401 =<< ( selectRep $ do provideRep $ do- setMessage $ toHtml msg- fmap asHtml $ redirect dest+ onErrorHtml dest msg provideJsonMessage msg )- where- asHtml :: Html -> Html- asHtml = id provideJsonMessage :: Monad m => Text -> Writer.Writer (Endo [ProvidedRep m]) () provideJsonMessage msg = provideRep $ return $ object ["message" .= msg]
Yesod/Auth/BrowserId.hs view
@@ -75,7 +75,8 @@ case memail of Nothing -> do $logErrorS "yesod-auth" "BrowserID assertion failure"- loginErrorMessage LoginR "BrowserID login error."+ tm <- getRouteToParent+ lift $ loginErrorMessage (tm LoginR) "BrowserID login error." Just email -> lift $ setCreds True Creds { credsPlugin = pid , credsIdent = email
Yesod/Auth/Email.hs view
@@ -393,15 +393,19 @@ Nothing -> loginErrorMessageI LoginR Msg.BadSetPass Just aid -> return aid + tm <- getRouteToParent+ needOld <- lift $ needOldPassword aid when needOld $ do current <- lift $ runInputPost $ ireq textField "current" mrealpass <- lift $ getPassword aid case mrealpass of- Nothing -> loginErrorMessage setpassR "You do not currently have a password set on your account"+ Nothing ->+ lift $ loginErrorMessage (tm setpassR) "You do not currently have a password set on your account" Just realpass | isValidPass current realpass -> return ()- | otherwise -> loginErrorMessage setpassR "Invalid current password, please try again"+ | otherwise ->+ lift $ loginErrorMessage (tm setpassR) "Invalid current password, please try again" (new, confirm) <- lift $ runInputPost $ (,) <$> ireq textField "new"@@ -411,7 +415,7 @@ isSecure <- lift $ checkPasswordSecurity aid new case isSecure of- Left e -> loginErrorMessage setpassR e+ Left e -> lift $ loginErrorMessage (tm setpassR) e Right () -> return () salted <- liftIO $ saltPass new
Yesod/Auth/GoogleEmail.hs view
@@ -54,7 +54,9 @@ , ("openid.ui.icon", "true") ] (authHttpManager master) either- (\err -> loginErrorMessage LoginR $ T.pack $ show (err :: SomeException))+ (\err -> do+ tm <- getRouteToParent+ lift $ loginErrorMessage (tm LoginR) $ T.pack $ show (err :: SomeException)) redirect eres dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues@@ -71,13 +73,15 @@ completeHelper gets' = do master <- lift getYesod eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)- either onFailure onSuccess eres+ tm <- getRouteToParent+ either (onFailure tm) (onSuccess tm) eres where- onFailure err = loginErrorMessage LoginR $ T.pack $ show (err :: SomeException)- onSuccess oir = do+ onFailure tm err = do+ 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 []- (_, False) -> loginErrorMessage LoginR "Only Google login is supported"- (Nothing, _) -> loginErrorMessage LoginR "No email address provided"+ (_, False) -> lift $ loginErrorMessage (tm LoginR) "Only Google login is supported"+ (Nothing, _) -> lift $ loginErrorMessage (tm LoginR) "No email address provided"
Yesod/Auth/HashDB.hs view
@@ -177,7 +177,9 @@ (validateUser <$> (uniq =<< mu) <*> mp) if isValid then lift $ setCreds True $ Creds "hashdb" (fromMaybe "" mu) []- else loginErrorMessage LoginR "Invalid username/password"+ else do+ tm <- getRouteToParent+ lift $ loginErrorMessage (tm LoginR) "Invalid username/password" -- | A drop in for the getAuthId method of your YesodAuth instance which
Yesod/Auth/OpenId.hs view
@@ -69,8 +69,10 @@ master <- lift getYesod eres <- lift $ try $ OpenId.getForwardUrl oid complete' Nothing extensionFields (authHttpManager master) case eres of- Left err -> loginErrorMessage LoginR $ T.pack $- show (err :: SomeException)+ Left err -> do+ tm <- getRouteToParent+ lift $ loginErrorMessage (tm LoginR) $ T.pack $+ show (err :: SomeException) Right x -> redirect x Nothing -> loginErrorMessageI LoginR Msg.NoOpenID dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues@@ -89,8 +91,10 @@ eres <- try $ OpenId.authenticateClaimed gets' (authHttpManager master) either onFailure onSuccess eres where- onFailure err = loginErrorMessage LoginR $ T.pack $- show (err :: SomeException)+ onFailure err = do + tm <- getRouteToParent+ lift $ loginErrorMessage (tm LoginR) $ T.pack $+ show (err :: SomeException) onSuccess oir = do let claimed = case OpenId.oirClaimed oir of
yesod-auth.cabal view
@@ -1,5 +1,5 @@ name: yesod-auth-version: 1.2.5.1+version: 1.2.5.2 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin@@ -34,8 +34,8 @@ , unordered-containers , yesod-form >= 1.3 && < 1.4 , transformers >= 0.2.2- , persistent >= 1.2 && < 1.3- , persistent-template >= 1.2 && < 1.3+ , persistent >= 1.2 && < 1.4+ , persistent-template >= 1.2 && < 1.4 , SHA >= 1.4.1.3 , http-conduit >= 1.5 , aeson >= 0.5