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

Json auth plugins

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)]
+                        provideJsonMessage "Invalid Login"
-                    sendResponse res
+                      )
-                Just ar -> do
+                Just ar -> loginErrorMessageMasterI ar Msg.InvalidLogin
-                    res <- selectRep $ do
-                        provideRepType typeHtml $ do
-                            setMessageI Msg.InvalidLogin
-                            _ <- redirect ar
-                            return ()
-                        provideRep $ return $ object ["message" .= ("Invalid Login" :: Text)]
-                    sendResponse res
         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
+data AuthException = InvalidFacebookResponse
-                   | InvalidFacebookResponse
     deriving (Show, Typeable)
 instance Exception AuthException
 

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

yesod-auth/Yesod/Auth/Email.hs

@@ -195,15 +195,13 @@ registerHelper allowUsername dest = do
     identifier <-
         case midentifier of
             Nothing -> do
-                lift $ setMessageI Msg.NoIdentifierProvided
+                loginErrorMessageI dest Msg.NoIdentifierProvided
-                redirect dest
             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
+                    loginErrorMessageI dest Msg.InvalidEmailAddress
-                    redirect dest
     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
+        Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
-            lift $ setMessageI Msg.BadSetPass
-            redirect LoginR
     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
+    when (new /= confirm) $
-        lift $ setMessageI Msg.PassMismatch
+        loginErrorMessageI setpassR Msg.PassMismatch
-        redirect setpassR
     maid <- lift maybeAuthId
     aid <- case maid of
-            Nothing -> do
+            Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
-                lift $ setMessageI Msg.BadSetPass
-                redirect LoginR
             Just aid -> return aid
     salted <- liftIO $ saltPass new
     lift $ do

yesod-auth/Yesod/Auth/GoogleEmail.hs

@@ -54,10 +54,7 @@ authGoogleEmail =
             , ("openid.ui.icon", "true")
             ] (authHttpManager master)
         either
-          (\err -> do
+          (\err -> loginErrorMessage LoginR $ T.pack $ show (err :: SomeException))
-                setMessage $ toHtml $ show (err :: SomeException)
-                redirect LoginR
-                )
           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
+      master <- lift getYesod
-        eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)
+      eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)
-        let onFailure err = do
+      either onFailure onSuccess eres
-            setMessage $ toHtml $ show (err :: SomeException)
+    where
-            redirect LoginR
+      onFailure err = loginErrorMessage LoginR $ T.pack $ show (err :: SomeException)
-        let onSuccess oir = do
+      onSuccess oir = do
-                let OpenId.Identifier ident = OpenId.oirOpLocal oir
+              let OpenId.Identifier ident = OpenId.oirOpLocal oir
-                memail <- lookupGetParam "openid.ext1.value.email"
+              memail <- lookupGetParam "openid.ext1.value.email"
-                case (memail, "https://www.google.com/accounts/o8/id" `T.isPrefixOf` ident) of
+              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 $ setCreds True $ Creds pid email []
-                    (_, False) -> do
+                  (_, False)   -> loginErrorMessage LoginR "Only Google login is supported"
-                        setMessage "Only Google login is supported"
+                  (Nothing, _) -> loginErrorMessage LoginR "No email address provided"
-                        redirect LoginR
-                    (Nothing, _) -> do
-                        setMessage "No email address provided"
-                        redirect LoginR
-        either onFailure onSuccess eres

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

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
+                    Left err -> loginErrorMessage LoginR $ T.pack $
-                        setMessage $ toHtml $ show (err :: SomeException)
+                                 show (err :: SomeException)
-                        redirect LoginR
                     Right x -> redirect x
-            Nothing -> do
+            Nothing -> loginErrorMessageI LoginR Msg.NoOpenID
-                lift $ setMessageI Msg.NoOpenID
-                redirect LoginR
     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
+    master <- lift getYesod
-        eres <- try $ OpenId.authenticateClaimed gets' (authHttpManager master)
+    eres <- try $ OpenId.authenticateClaimed gets' (authHttpManager master)
-        let onFailure err = do
+    either onFailure onSuccess eres
-            setMessage $ toHtml $ show (err :: SomeException)
+  where
-            redirect LoginR
+    onFailure err = loginErrorMessage LoginR $ T.pack $
-        let onSuccess oir = do
+                      show (err :: SomeException)
-                let claimed =
+    onSuccess oir = do
-                        case OpenId.oirClaimed oir of
+            let claimed =
-                            Nothing -> id
+                    case OpenId.oirClaimed oir of
-                            Just (OpenId.Identifier i') -> ((claimedKey, i'):)
+                        Nothing -> id
-                    oplocal =
+                        Just (OpenId.Identifier i') -> ((claimedKey, i'):)
-                        case OpenId.oirOpLocal oir of
+                oplocal =
-                            OpenId.Identifier i' -> ((opLocalKey, i'):)
+                    case OpenId.oirOpLocal oir of
-                    gets'' = oplocal $ claimed $ filter (\(k, _) -> not $ "__" `isPrefixOf` k) gets'
+                        OpenId.Identifier i' -> ((opLocalKey, i'):)
-                    i = OpenId.identifier $
+                gets'' = oplocal $ claimed $ filter (\(k, _) -> not $ "__" `isPrefixOf` k) gets'
-                            case idType of
+                i = OpenId.identifier $
-                                OPLocal -> OpenId.oirOpLocal oir
+                        case idType of
-                                Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir
+                            OPLocal -> OpenId.oirOpLocal oir
-                lift $ setCreds True $ Creds "openid" i gets''
+                            Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir
-        either onFailure onSuccess eres
+            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