haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

yesod-auth: send json responses

Browse Source
This commit is contained in:
Greg Weber 2014-01-08 10:43:00 -08:00
parent 12480b2d2a
commit 153654adb9
9 changed files with 190 additions and 141 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

93
yesod-auth/Yesod/Auth.hs
View File

@ -22,6 +22,7 @@ module Yesod.Auth
-- * Plugin interface
, Creds (..)
, setCreds
, setCredsRedirect
, clearCreds
, loginErrorMessage
, loginErrorMessageI
@ -36,6 +37,9 @@ module Yesod.Auth
, AuthHandler
-- * Internal
, credsKey
, provideJsonMessage
, messageJson401
, asHtml
) where
import Control.Monad (when)
@ -64,6 +68,7 @@ import Control.Exception (Exception)
import Network.HTTP.Types (unauthorized401)
import Control.Monad.Trans.Resource (MonadResourceBase)
import qualified Control.Monad.Trans.Writer as Writer
import Control.Monad (void)
type AuthRoute = Route Auth
@ -74,7 +79,7 @@ type Piece = Text
data AuthPlugin master = AuthPlugin
{ apName :: Text
, apDispatch :: Method -> [Piece] -> AuthHandler master ()
, apDispatch :: Method -> [Piece] -> AuthHandler master TypedContent
, apLogin :: (Route Auth -> Route master) -> WidgetT master IO ()
}
@ -106,7 +111,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
authPlugins :: master -> [AuthPlugin master]
-- | What to show on the login page.
loginHandler :: AuthHandler master RepHtml
loginHandler :: AuthHandler master Html
loginHandler = do
tp <- getRouteToParent
lift $ defaultLayout $ do
@ -171,9 +176,6 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
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.
--
@ -227,7 +229,7 @@ cachedAuth aid = runMaybeT $ do
loginErrorMessageI :: (MonadResourceBase m, YesodAuth master)
=> Route child
-> AuthMessage
-> HandlerT child (HandlerT master m) a
-> HandlerT child (HandlerT master m) TypedContent
loginErrorMessageI dest msg = do
toParent <- getRouteToParent
lift $ loginErrorMessageMasterI (toParent dest) msg
@ -236,7 +238,7 @@ loginErrorMessageI dest msg = do
loginErrorMessageMasterI :: (YesodAuth master, MonadResourceBase m, RenderMessage master AuthMessage)
=> Route master
-> AuthMessage
-> HandlerT master m a
-> HandlerT master m TypedContent
loginErrorMessageMasterI dest msg = do
mr <- getMessageRender
loginErrorMessage dest (mr msg)
@ -246,47 +248,55 @@ loginErrorMessageMasterI dest msg = do
loginErrorMessage :: (YesodAuth master, MonadResourceBase m)
=> Route master
-> Text
-> HandlerT master m a
loginErrorMessage dest msg =
sendResponseStatus unauthorized401 =<< (
selectRep $ do
provideRep $ do
onErrorHtml dest msg
provideJsonMessage msg
)
-> HandlerT master m TypedContent
loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg)
messageJson401 :: MonadResourceBase m => Text -> HandlerT master m Html -> HandlerT master m TypedContent
messageJson401 msg html = selectRep $ do
provideRep html
provideRep $ do
let obj = object ["message" .= msg]
void $ sendResponseStatus unauthorized401 obj
return obj
provideJsonMessage :: Monad m => Text -> Writer.Writer (Endo [ProvidedRep m]) ()
provideJsonMessage msg = provideRep $ return $ object ["message" .= msg]
setCredsRedirect :: YesodAuth master
=> Creds master -- ^ new credentials
-> HandlerT master IO TypedContent
setCredsRedirect creds = do
y <- getYesod
maid <- getAuthId creds
case maid of
Nothing ->
case authRoute y of
Nothing -> do
messageJson401 "Invalid Login" $ defaultLayout $
toWidget [shamlet|<h1>Invalid login|]
Just ar -> loginErrorMessageMasterI ar Msg.InvalidLogin
Just aid -> do
setSession credsKey $ toPathPiece aid
onLogin
res <- selectRep $ do
provideRepType typeHtml $
fmap asHtml $ redirectUltDest $ loginDest y
provideJsonMessage "Login Successful"
sendResponse res
-- | Sets user credentials for the session after checking them with authentication backends.
setCreds :: YesodAuth master
=> Bool -- ^ if HTTP redirects should be done
-> Creds master -- ^ new credentials
-> HandlerT master IO ()
setCreds doRedirects creds = do
y <- getYesod
maid <- getAuthId creds
case maid of
Nothing -> when doRedirects $ do
case authRoute y of
Nothing -> do
sendResponseStatus unauthorized401 =<< (
selectRep $ do
provideRep $ defaultLayout $ toWidget [shamlet|<h1>Invalid login|]
provideJsonMessage "Invalid Login"
)
Just ar -> loginErrorMessageMasterI ar Msg.InvalidLogin
Just aid -> do
setSession credsKey $ toPathPiece aid
when doRedirects $ do
onLogin
res <- selectRep $ do
provideRepType typeHtml $ do
_ <- redirectUltDest $ loginDest y
return ()
provideJsonMessage "Login Successful"
sendResponse res
setCreds doRedirects creds =
if doRedirects
then void $ setCredsRedirect creds
else do maid <- getAuthId creds
case maid of
Nothing -> return ()
Just aid -> setSession credsKey $ toPathPiece aid
-- | Clears current user credentials for the session.
--
@ -327,7 +337,7 @@ setUltDestReferer' = lift $ do
master <- getYesod
when (redirectToReferer master) setUltDestReferer
getLoginR :: AuthHandler master RepHtml
getLoginR :: AuthHandler master Html
getLoginR = setUltDestReferer' >> loginHandler
getLogoutR :: AuthHandler master ()
@ -336,7 +346,7 @@ getLogoutR = setUltDestReferer' >> redirectToPost LogoutR
postLogoutR :: AuthHandler master ()
postLogoutR = lift $ clearCreds True
handlePluginR :: Text -> [Text] -> AuthHandler master ()
handlePluginR :: Text -> [Text] -> AuthHandler master TypedContent
handlePluginR plugin pieces = do
master <- lift getYesod
env <- waiRequest
@ -423,3 +433,6 @@ instance Exception AuthException
instance YesodAuth master => YesodSubDispatch Auth (HandlerT master IO) where
yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth)
asHtml :: Html -> Html
asHtml = id

2
yesod-auth/Yesod/Auth/BrowserId.hs
View File

@ -77,7 +77,7 @@ authBrowserId bis@BrowserIdSettings {..} = AuthPlugin
$logErrorS "yesod-auth" "BrowserID assertion failure"
tm <- getRouteToParent
lift $ loginErrorMessage (tm LoginR) "BrowserID login error."
Just email -> lift $ setCreds True Creds
Just email -> lift $ setCredsRedirect Creds
{ credsPlugin = pid
, credsIdent = email
, credsExtra = []

2
yesod-auth/Yesod/Auth/Dummy.hs
View File

@ -18,7 +18,7 @@ authDummy =
where
dispatch "POST" [] = do
ident <- lift $ runInputPost $ ireq textField "ident"
lift $ setCreds True $ Creds "dummy" ident []
lift $ setCredsRedirect $ Creds "dummy" ident []
dispatch _ _ = notFound
url = PluginR "dummy" []
login authToMaster =

209
yesod-auth/Yesod/Auth/Email.hs
View File

@ -41,8 +41,8 @@ import qualified Crypto.PasswordStore as PS
import qualified Text.Email.Validate
import qualified Yesod.Auth.Message as Msg
import Control.Applicative ((<$>), (<*>))
import Control.Monad (void)
import Yesod.Form
import Control.Monad (when)
import Data.Time (getCurrentTime, addUTCTime)
import Safe (readMay)
@ -78,7 +78,11 @@ data EmailCreds site = EmailCreds
, emailCredsEmail :: Email
}
class (YesodAuth site, PathPiece (AuthEmailId site)) => YesodAuthEmail site where
class ( YesodAuth site
, PathPiece (AuthEmailId site)
, (RenderMessage site Msg.AuthMessage)
)
=> YesodAuthEmail site where
type AuthEmailId site
-- | Add a new email address to the database, but indicate that the address
@ -167,10 +171,14 @@ class (YesodAuth site, PathPiece (AuthEmailId site)) => YesodAuthEmail site wher
-- | Response after sending a confirmation email.
--
-- Since 1.2.2
confirmationEmailSentResponse :: Text -> HandlerT site IO Html
confirmationEmailSentResponse identifier = defaultLayout $ do
setTitleI Msg.ConfirmationEmailSentTitle
[whamlet|<p>_{Msg.ConfirmationEmailSent identifier}|]
confirmationEmailSentResponse :: Text -> HandlerT site IO TypedContent
confirmationEmailSentResponse identifier = do
mr <- getMessageRender
messageJson401 (mr msg) $ defaultLayout $ do
setTitleI Msg.ConfirmationEmailSentTitle
[whamlet|<p>_{msg}|]
where
msg = Msg.ConfirmationEmailSent identifier
-- | Additional normalization of email addresses, besides standard canonicalization.
--
@ -183,6 +191,7 @@ class (YesodAuth site, PathPiece (AuthEmailId site)) => YesodAuthEmail site wher
normalizeEmailAddress :: site -> Text -> Text
normalizeEmailAddress _ = TS.toLower
authEmail :: YesodAuthEmail m => AuthPlugin m
authEmail =
AuthPlugin "email" dispatch $ \tm ->
@ -235,40 +244,46 @@ getRegisterR = do
registerHelper :: YesodAuthEmail master
=> Bool -- ^ allow usernames?
-> Route Auth
-> HandlerT Auth (HandlerT master IO) Html
-> HandlerT Auth (HandlerT master IO) TypedContent
registerHelper allowUsername dest = do
y <- lift getYesod
midentifier <- lookupPostParam "email"
identifier <-
case midentifier of
Nothing -> loginErrorMessageI dest Msg.NoIdentifierProvided
let eidentifier = case midentifier of
Nothing -> Left Msg.NoIdentifierProvided
Just x
| Just x' <- Text.Email.Validate.canonicalizeEmail (encodeUtf8 x) ->
return $ normalizeEmailAddress y $ decodeUtf8With lenientDecode x'
| allowUsername -> return $ TS.strip x
| otherwise -> loginErrorMessageI dest Msg.InvalidEmailAddress
Right $ normalizeEmailAddress y $ decodeUtf8With lenientDecode x'
| allowUsername -> Right $ TS.strip x
| otherwise -> Left Msg.InvalidEmailAddress
mecreds <- lift $ getEmailCreds identifier
(lid, verKey, email) <-
case mecreds of
Just (EmailCreds lid _ _ (Just key) email) -> return (lid, key, email)
Just (EmailCreds lid _ _ Nothing email) -> do
key <- liftIO $ randomKey y
lift $ setVerifyKey lid key
return (lid, key, email)
Nothing
| allowUsername ->
loginErrorMessageI dest (Msg.IdentifierNotFound identifier)
| otherwise -> do
key <- liftIO $ randomKey y
lid <- lift $ addUnverified identifier key
return (lid, key, identifier)
render <- getUrlRender
let verUrl = render $ verify (toPathPiece lid) verKey
lift $ sendVerifyEmail email verKey verUrl
lift $ confirmationEmailSentResponse identifier
case eidentifier of
Left route -> loginErrorMessageI dest route
Right identifier -> do
postRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
mecreds <- lift $ getEmailCreds identifier
registerCreds <-
case mecreds of
Just (EmailCreds lid _ _ (Just key) email) -> return $ Just (lid, key, email)
Just (EmailCreds lid _ _ Nothing email) -> do
key <- liftIO $ randomKey y
lift $ setVerifyKey lid key
return $ Just (lid, key, email)
Nothing
| allowUsername -> return Nothing
| otherwise -> do
key <- liftIO $ randomKey y
lid <- lift $ addUnverified identifier key
return $ Just (lid, key, identifier)
case registerCreds of
Nothing -> loginErrorMessageI dest (Msg.IdentifierNotFound identifier)
Just (lid, verKey, email) -> do
render <- getUrlRender
let verUrl = render $ verify (toPathPiece lid) verKey
lift $ sendVerifyEmail email verKey verUrl
lift $ confirmationEmailSentResponse identifier
postRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
postRegisterR = registerHelper False registerR
getForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
@ -286,35 +301,43 @@ getForgotPasswordR = do
<button .btn>_{Msg.SendPasswordResetEmail}
|]
postForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
postForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
postForgotPasswordR = registerHelper True forgotPasswordR
getVerifyR :: YesodAuthEmail site
=> AuthEmailId site
-> Text
-> HandlerT Auth (HandlerT site IO) Html
-> HandlerT Auth (HandlerT site IO) TypedContent
getVerifyR lid key = do
realKey <- lift $ getVerifyKey lid
memail <- lift $ getEmail lid
mr <- lift getMessageRender
case (realKey == Just key, memail) of
(True, Just email) -> do
muid <- lift $ verifyAccount lid
case muid of
Nothing -> return ()
Nothing -> invalidKey mr
Just uid -> do
lift $ setCreds False $ Creds "email-verify" email [("verifiedEmail", email)] -- FIXME uid?
lift $ setMessageI Msg.AddressVerified
lift $ setLoginLinkKey uid
redirect setpassR
_ -> return ()
lift $ defaultLayout $ do
setTitleI Msg.InvalidKey
let msgAv = Msg.AddressVerified
selectRep $ do
provideRep $ do
lift $ setMessageI msgAv
fmap asHtml $ redirect setpassR
provideJsonMessage $ mr msgAv
_ -> invalidKey mr
where
msgIk = Msg.InvalidKey
invalidKey mr = messageJson401 (mr msgIk) $ lift $ defaultLayout $ do
setTitleI msgIk
[whamlet|
$newline never
<p>_{Msg.InvalidKey}
<p>_{msgIk}
|]
postLoginR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) ()
postLoginR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
postLoginR = do
(identifier, pass) <- lift $ runInputPost $ (,)
<$> ireq textField "email"
@ -337,30 +360,33 @@ postLoginR = do
let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier
case maid of
Just email ->
lift $ setCreds True $ Creds
lift $ setCredsRedirect $ Creds
(if isEmail then "email" else "username")
email
[("verifiedEmail", email)]
Nothing -> do
Nothing ->
loginErrorMessageI LoginR $
if isEmail
then Msg.InvalidEmailPass
else Msg.InvalidUsernamePass
getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
getPasswordR = do
maid <- lift maybeAuthId
pass0 <- newIdent
pass1 <- newIdent
pass2 <- newIdent
case maid of
Just _ -> return ()
Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
tp <- getRouteToParent
needOld <- maybe (return True) (lift . needOldPassword) maid
lift $ defaultLayout $ do
setTitleI Msg.SetPassTitle
[whamlet|
Just _ -> do
pass0 <- newIdent
pass1 <- newIdent
pass2 <- newIdent
tp <- getRouteToParent
needOld <- maybe (return True) (lift . needOldPassword) maid
mr <- lift getMessageRender
selectRep $ do
provideJsonMessage $ mr Msg.SetPass
provideRep $ lift $ defaultLayout $ do
setTitleI Msg.SetPassTitle
[whamlet|
$newline never
<h3>_{Msg.SetPass}
<form method="post" action="@{tp setpassR}">
@ -386,45 +412,52 @@ $newline never
<input type="submit" value=_{Msg.SetPassTitle}>
|]
postPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) ()
postPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
postPasswordR = do
maid <- lift maybeAuthId
aid <- case maid of
Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
Just aid -> return aid
case maid of
Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
Just aid -> do
tm <- getRouteToParent
tm <- getRouteToParent
needOld <- lift $ needOldPassword aid
when needOld $ do
current <- lift $ runInputPost $ ireq textField "current"
mrealpass <- lift $ getPassword aid
case mrealpass of
Nothing ->
lift $ loginErrorMessage (tm setpassR) "You do not currently have a password set on your account"
Just realpass
| isValidPass current realpass -> return ()
| otherwise ->
lift $ loginErrorMessage (tm setpassR) "Invalid current password, please try again"
needOld <- lift $ needOldPassword aid
if not needOld then confirmPassword aid tm else do
current <- lift $ runInputPost $ ireq textField "current"
mrealpass <- lift $ getPassword aid
case mrealpass of
Nothing ->
lift $ loginErrorMessage (tm setpassR) "You do not currently have a password set on your account"
Just realpass
| isValidPass current realpass -> confirmPassword aid tm
| otherwise ->
lift $ loginErrorMessage (tm setpassR) "Invalid current password, please try again"
(new, confirm) <- lift $ runInputPost $ (,)
<$> ireq textField "new"
<*> ireq textField "confirm"
when (new /= confirm) $
loginErrorMessageI setpassR Msg.PassMismatch
where
msgOk = Msg.PassUpdated
confirmPassword aid tm = do
(new, confirm) <- lift $ runInputPost $ (,)
<$> ireq textField "new"
<*> ireq textField "confirm"
isSecure <- lift $ checkPasswordSecurity aid new
case isSecure of
Left e -> lift $ loginErrorMessage (tm setpassR) e
Right () -> return ()
if new /= confirm
then loginErrorMessageI setpassR Msg.PassMismatch
else do
isSecure <- lift $ checkPasswordSecurity aid new
case isSecure of
Left e -> lift $ loginErrorMessage (tm setpassR) e
Right () -> do
salted <- liftIO $ saltPass new
y <- lift $ do
setPassword aid salted
deleteSession loginLinkKey
setMessageI msgOk
getYesod
salted <- liftIO $ saltPass new
lift $ do
y <- getYesod
setPassword aid salted
setMessageI Msg.PassUpdated
deleteSession loginLinkKey
redirect $ afterPasswordRoute y
mr <- lift getMessageRender
selectRep $ do
provideRep $
fmap asHtml $ lift $ redirect $ afterPasswordRoute y
provideJsonMessage (mr msgOk)
saltLength :: Int
saltLength = 5

6
yesod-auth/Yesod/Auth/GoogleEmail.hs
View File

@ -69,19 +69,19 @@ authGoogleEmail =
completeHelper posts
dispatch _ _ = notFound
completeHelper :: YesodAuth master => [(Text, Text)] -> AuthHandler master ()
completeHelper :: YesodAuth master => [(Text, Text)] -> AuthHandler master TypedContent
completeHelper gets' = do
master <- lift getYesod
eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)
tm <- getRouteToParent
either (onFailure tm) (onSuccess tm) eres
where
onFailure tm err = do
onFailure tm err =
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 []
(Just email, True) -> lift $ setCredsRedirect $ Creds pid email []
(_, False) -> lift $ loginErrorMessage (tm LoginR) "Only Google login is supported"
(Nothing, _) -> lift $ loginErrorMessage (tm LoginR) "No email address provided"

11
yesod-auth/Yesod/Auth/HashDB.hs
View File

@ -82,7 +82,7 @@ import Yesod.Core
import Text.Hamlet (hamlet)
import Control.Applicative ((<$>), (<*>))
import Control.Monad (replicateM,liftM)
import Control.Monad (replicateM, liftM, void)
import Data.Typeable
import qualified Data.ByteString.Lazy.Char8 as BS (pack)
@ -90,6 +90,7 @@ import Data.Digest.Pure.SHA (sha1, showDigest)
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
@ -167,7 +168,7 @@ postLoginR :: ( YesodAuth y, YesodPersist y
, PersistUnique (b (HandlerT y IO))
)
=> (Text -> Maybe (Unique user))
-> HandlerT Auth (HandlerT y IO) ()
-> HandlerT Auth (HandlerT y IO) TypedContent
postLoginR uniq = do
(mu,mp) <- lift $ runInputPost $ (,)
<$> iopt textField "username"
@ -176,7 +177,7 @@ postLoginR uniq = do
isValid <- lift $ fromMaybe (return False)
(validateUser <$> (uniq =<< mu) <*> mp)
if isValid
then lift $ setCreds True $ Creds "hashdb" (fromMaybe "" mu) []
then lift $ setCredsRedirect $ Creds "hashdb" (fromMaybe "" mu) []
else do
tm <- getRouteToParent
lift $ loginErrorMessage (tm LoginR) "Invalid username/password"
@ -207,7 +208,9 @@ getAuthIdHashDB authR uniq creds = do
case x of
-- user exists
Just (Entity uid _) -> return $ Just uid
Nothing -> loginErrorMessage (authR LoginR) "User not found"
Nothing -> do
void $ loginErrorMessage (authR LoginR) "User not found"
return Nothing
-- | Prompt for username and password, validate that against a database
-- which holds the username and a hash of the password

4
yesod-auth/Yesod/Auth/OpenId.hs
View File

@ -85,7 +85,7 @@ $newline never
completeHelper idType posts
dispatch _ _ = notFound
completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master ()
completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent
completeHelper idType gets' = do
master <- lift getYesod
eres <- try $ OpenId.authenticateClaimed gets' (authHttpManager master)
@ -108,7 +108,7 @@ completeHelper idType gets' = do
case idType of
OPLocal -> OpenId.oirOpLocal oir
Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir
lift $ setCreds True $ Creds "openid" i gets''
lift $ setCredsRedirect $ 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

2
yesod-auth/Yesod/Auth/Rpxnow.hs
View File

@ -48,7 +48,7 @@ $newline never
$ maybe id (\x -> (:) ("displayName", x))
(fmap pack $ getDisplayName $ map (unpack *** unpack) extra)
[]
lift $ setCreds True creds
lift $ setCredsRedirect creds
dispatch _ _ = notFound
-- | Get some form of a display name.

2
yesod-auth/yesod-auth.cabal
View File

@ -1,5 +1,5 @@
name: yesod-auth
version: 1.2.5.2
version: 1.3.0.0
license: MIT
license-file: LICENSE
author: Michael Snoyman, Patrick Brisbin