Merge pull request #553 from yesodweb/json-auth-plugins

Json auth plugins
2013-05-11 23:06:33 -07:00 · 2013-05-11 23:06:33 -07:00 · 7ace5dde01
commit 7ace5dde01
parent 89203d0630 0c9abba5c1
6 changed files with 104 additions and 98 deletions
--- a/yesod-auth/Yesod/Auth.hs
+++ b/yesod-auth/Yesod/Auth.hs
@ -23,6 +23,8 @@ module Yesod.Auth
    , Creds (..)
    , setCreds
    , clearCreds
+    , loginErrorMessage
+    , loginErrorMessageI
      -- * User functions
    , defaultMaybeAuthId
    , maybeAuth
@ -44,6 +46,7 @@ import Data.Text.Encoding.Error (lenientDecode)
 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 qualified Yesod.Auth.Message as Msg
 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 @@ cachedAuth aid = runMaybeT $ do
                $ 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 @@ setCreds doRedirects creds = do
        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 @@ setCreds doRedirects creds = do
                  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 @@ redirectLogin = do
 instance YesodAuth master => RenderMessage master AuthMessage where
    renderMessage = renderAuthMessage

-data AuthException = InvalidBrowserIDAssertion
-                   | InvalidFacebookResponse
+data AuthException = InvalidFacebookResponse
    deriving (Show, Typeable)
 instance Exception AuthException

--- a/yesod-auth/Yesod/Auth/BrowserId.hs
+++ b/yesod-auth/Yesod/Auth/BrowserId.hs
@ -19,7 +19,6 @@ import Text.Hamlet (hamlet)
 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 @@ authBrowserId bis@BrowserIdSettings {..} = AuthPlugin
                            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
--- a/yesod-auth/Yesod/Auth/Email.hs
+++ b/yesod-auth/Yesod/Auth/Email.hs
@ -195,15 +195,13 @@ registerHelper allowUsername dest = do
    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 @@ postLoginR = do
                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 @@ getPasswordR = do
    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 @@ postPasswordR = do
    (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
--- a/yesod-auth/Yesod/Auth/GoogleEmail.hs
+++ b/yesod-auth/Yesod/Auth/GoogleEmail.hs
@ -54,10 +54,7 @@ authGoogleEmail =
            , ("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 @@ authGoogleEmail =

 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"
--- a/yesod-auth/Yesod/Auth/HashDB.hs
+++ b/yesod-auth/Yesod/Auth/HashDB.hs
@ -82,14 +82,12 @@ import Text.Hamlet (hamlet)

 import Control.Applicative         ((<$>), (<*>))
 import Control.Monad               (replicateM,liftM)
-import Control.Monad.Trans.Resource (MonadResourceBase)

 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)
-import Network.HTTP.Types          (unauthorized401)
 -- | Interface for data type which holds user info. It's just a
 --   collection of getters and setters
 class HashDBUser user where
@ -177,22 +175,8 @@ postLoginR uniq = do
                 (validateUser <$> (uniq =<< mu) <*> mp)
    if isValid 
       then lift $ setCreds True $ Creds "hashdb" (fromMaybe "" mu) []
-       else loginMsg LoginR "Invalid username/password"
+       else loginErrorMessage LoginR "Invalid username/password"

-loginMsg :: MonadResourceBase m
-         => Route site
-         -> Text
-         -> HandlerT site m a
-loginMsg dest msg = selectRep (do
-    provideRep $ do
-        setMessage $ toHtml msg
-        fmap asHtml $ redirect dest
-    provideRep $ return $ object
-        [ "message" .= msg
-        ]) >>= sendResponseStatus unauthorized401
-  where
-    asHtml :: Html -> Html
-    asHtml = id

 -- | A drop in for the getAuthId method of your YesodAuth instance which
 --   can be used if authHashDB is the only plugin in use.
@ -219,7 +203,7 @@ getAuthIdHashDB authR uniq creds = do
            case x of
                -- user exists
                Just (Entity uid _) -> return $ Just uid
-                Nothing       -> loginMsg (authR LoginR) "User not found"
+                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
--- a/yesod-auth/Yesod/Auth/OpenId.hs
+++ b/yesod-auth/Yesod/Auth/OpenId.hs
@ -21,16 +21,17 @@ import Data.Text (Text, isPrefixOf)
 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 @@ $newline never
                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 @@ $newline never

 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