yesod-auth 0.7.9 → 0.8.1
raw patch · 12 files changed
+167/−459 lines, 12 filesdep +http-conduitdep +lifted-basedep −control-monad-attemptdep −http-enumeratordep ~aesondep ~authenticatedep ~persistent
Dependencies added: http-conduit, lifted-base
Dependencies removed: control-monad-attempt, http-enumerator
Dependency ranges changed: aeson, authenticate, persistent, persistent-template, wai, yesod-core, yesod-form, yesod-json, yesod-persistent
Files
- Yesod/Auth.hs +55/−23
- Yesod/Auth/BrowserId.hs +29/−36
- Yesod/Auth/Email.hs +9/−9
- Yesod/Auth/Facebook.hs +0/−123
- Yesod/Auth/GoogleEmail.hs +18/−16
- Yesod/Auth/HashDB.hs +21/−13
- Yesod/Auth/Kerberos.hs +0/−118
- Yesod/Auth/Message.hs +6/−0
- Yesod/Auth/OAuth.hs +0/−88
- Yesod/Auth/OpenId.hs +14/−15
- Yesod/Auth/Rpxnow.hs +2/−2
- yesod-auth.cabal +13/−16
Yesod/Auth.hs view
@@ -5,12 +5,14 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Yesod.Auth ( -- * Subsite Auth+ , AuthRoute+ , Route (..) , AuthPlugin (..)- , AuthRoute (..) , getAuth , YesodAuth (..) -- * Plugin interface@@ -21,12 +23,13 @@ , maybeAuth , requireAuthId , requireAuth+ -- * Exception+ , AuthException (..) ) where #include "qq.h" import Control.Monad (when) -import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe import Data.Aeson@@ -34,11 +37,8 @@ import Data.Text.Encoding.Error (lenientDecode) import Data.Text (Text) import qualified Data.Text as T-#if MIN_VERSION_aeson(0, 4, 0) import qualified Data.HashMap.Lazy as Map-#else-import qualified Data.Map as Map-#endif+import Network.HTTP.Conduit (Manager) import Language.Haskell.TH.Syntax hiding (lift) @@ -51,9 +51,13 @@ import Yesod.Auth.Message (AuthMessage, defaultMessage) import qualified Yesod.Auth.Message as Msg import Yesod.Form (FormMessage)+import Data.Typeable (Typeable)+import Control.Exception (Exception) data Auth = Auth +type AuthRoute = Route Auth+ type Method = Text type Piece = Text @@ -73,7 +77,7 @@ , credsExtra :: [(Text, Text)] } -class (Yesod m, SinglePiece (AuthId m), RenderMessage m FormMessage) => YesodAuth m where+class (Yesod m, PathPiece (AuthId m), RenderMessage m FormMessage) => YesodAuth m where type AuthId m -- | Default destination on successful login, if no other@@ -84,17 +88,21 @@ -- destination exists. logoutDest :: m -> Route m + -- | Determine the ID associated with the set of credentials. getAuthId :: Creds m -> GHandler s m (Maybe (AuthId m)) - authPlugins :: [AuthPlugin m]+ -- | Which authentication backends to use.+ authPlugins :: m -> [AuthPlugin m] -- | What to show on the login page. loginHandler :: GHandler Auth m RepHtml loginHandler = defaultLayout $ do setTitleI Msg.LoginTitle tm <- lift getRouteToMaster- mapM_ (flip apLogin tm) authPlugins+ master <- lift getYesod+ mapM_ (flip apLogin tm) (authPlugins master) + -- | Used for i18n of messages provided by this package. renderAuthMessage :: m -> [Text] -- ^ languages -> AuthMessage -> Text@@ -105,6 +113,21 @@ redirectToReferer :: m -> Bool redirectToReferer _ = False + -- | Return an HTTP connection manager that is stored in the foundation+ -- type. This allows backends to reuse persistent connections. If none of+ -- the backends you're using use HTTP connections, you can safely return+ -- @error \"authHttpManager"@ here.+ authHttpManager :: m -> Manager++ -- | Called on a successful login. By default, calls+ -- @setMessageI NowLoggedIn@.+ onLogin :: GHandler s m ()+ onLogin = setMessageI Msg.NowLoggedIn++ -- | Called on logout. By default, does nothing+ onLogout :: GHandler s m ()+ onLogout = return ()+ mkYesodSub "Auth" [ ClassP ''YesodAuth [VarT $ mkName "master"] ]@@ -131,12 +154,12 @@ Nothing -> do rh <- defaultLayout $ addHtml [QQ(shamlet)| <h1>Invalid login |] sendResponse rh Just ar -> do setMessageI Msg.InvalidLogin- redirect RedirectTemporary ar+ redirect ar Just aid -> do- setSession credsKey $ toSinglePiece aid+ setSession credsKey $ toPathPiece aid when doRedirects $ do- setMessageI Msg.NowLoggedIn- redirectUltDest RedirectTemporary $ loginDest y+ onLogin+ redirectUltDest $ loginDest y getCheckR :: YesodAuth m => GHandler Auth m RepHtmlJson getCheckR = do@@ -173,13 +196,15 @@ postLogoutR = do y <- getYesod deleteSession credsKey- redirectUltDest RedirectTemporary $ logoutDest y+ onLogout+ redirectUltDest $ logoutDest y handlePluginR :: YesodAuth m => Text -> [Text] -> GHandler Auth m () handlePluginR plugin pieces = do+ master <- getYesod env <- waiRequest let method = decodeUtf8With lenientDecode $ W.requestMethod env- case filter (\x -> apName x == plugin) authPlugins of+ case filter (\x -> apName x == plugin) (authPlugins master) of [] -> notFound ap:_ -> apDispatch ap method pieces @@ -189,39 +214,46 @@ ms <- lookupSession credsKey case ms of Nothing -> return Nothing- Just s -> return $ fromSinglePiece s+ Just s -> return $ fromPathPiece s maybeAuth :: ( YesodAuth m , b ~ YesodPersistBackend m+ , b ~ PersistEntityBackend val , Key b val ~ AuthId m- , PersistBackend b (GGHandler s m IO)+ , PersistStore b (GHandler s m) , PersistEntity val , YesodPersist m- ) => GHandler s m (Maybe (Key b val, val))+ ) => GHandler s m (Maybe (Entity val)) maybeAuth = runMaybeT $ do aid <- MaybeT $ maybeAuthId a <- MaybeT $ runDB $ get aid- return (aid, a)+ return $ Entity aid a requireAuthId :: YesodAuth m => GHandler s m (AuthId m) requireAuthId = maybeAuthId >>= maybe redirectLogin return requireAuth :: ( YesodAuth m , b ~ YesodPersistBackend m+ , b ~ PersistEntityBackend val , Key b val ~ AuthId m- , PersistBackend b (GGHandler s m IO)+ , PersistStore b (GHandler s m) , PersistEntity val , YesodPersist m- ) => GHandler s m (Key b val, val)+ ) => GHandler s m (Entity val) requireAuth = maybeAuth >>= maybe redirectLogin return redirectLogin :: Yesod m => GHandler s m a redirectLogin = do y <- getYesod- setUltDest'+ setUltDestCurrent case authRoute y of- Just z -> redirect RedirectTemporary z+ Just z -> redirect z Nothing -> permissionDenied "Please configure authRoute" instance YesodAuth m => RenderMessage m AuthMessage where renderMessage = renderAuthMessage++data AuthException = InvalidBrowserIDAssertion+ | InvalidFacebookResponse+ deriving (Show, Typeable)+instance Exception AuthException
Yesod/Auth/BrowserId.hs view
@@ -3,7 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} module Yesod.Auth.BrowserId ( authBrowserId- , authBrowserId'+ , authBrowserIdAudience ) where import Yesod.Auth@@ -11,57 +11,50 @@ import Data.Text (Text) import Yesod.Core import Text.Hamlet (hamlet)-import Control.Monad.IO.Class (liftIO) import qualified Data.Text as T import Data.Maybe (fromMaybe)+import Control.Monad.IO.Class (liftIO)+import Control.Exception (throwIO) #include "qq.h" pid :: Text pid = "browserid" -complete :: AuthRoute+complete :: Route Auth complete = PluginR pid [] -authBrowserId :: YesodAuth m- => Text -- ^ audience- -> AuthPlugin m-authBrowserId audience = AuthPlugin- { apName = pid- , apDispatch = \m ps ->- case (m, ps) of- ("GET", [assertion]) -> do- memail <- liftIO $ checkAssertion audience assertion- case memail of- Nothing -> error "Invalid assertion"- Just email -> setCreds True Creds- { credsPlugin = pid- , credsIdent = email- , credsExtra = []- }- (_, []) -> badMethod- _ -> notFound- , apLogin = \toMaster -> do- addScriptRemote browserIdJs- addHamlet [QQ(hamlet)|-<p>- <a href="javascript:navigator.id.getVerifiedEmail(function(a){if(a)document.location='@{toMaster complete}/'+a});">- <img src="https://browserid.org/i/sign_in_green.png">-|]- }+-- | Log into browser ID with an audience value determined from the 'approot'.+authBrowserId :: YesodAuth m => AuthPlugin m+authBrowserId = helper Nothing -authBrowserId' :: YesodAuth m => AuthPlugin m-authBrowserId' = AuthPlugin+-- | Log into browser ID with the given audience value. Note that this must be+-- your actual hostname, or login will fail.+authBrowserIdAudience+ :: YesodAuth m+ => Text -- ^ audience+ -> AuthPlugin m+authBrowserIdAudience = helper . Just++helper :: YesodAuth m+ => Maybe Text -- ^ audience+ -> AuthPlugin m+helper maudience = AuthPlugin { apName = pid , apDispatch = \m ps -> case (m, ps) of ("GET", [assertion]) -> do- tm <- getRouteToMaster- r <- getUrlRender- let audience = T.takeWhile (/= '/') $ stripScheme $ r $ tm LoginR- memail <- liftIO $ checkAssertion audience assertion+ master <- getYesod+ audience <-+ case maudience of+ Just a -> return a+ Nothing -> do+ tm <- getRouteToMaster+ r <- getUrlRender+ return $ T.takeWhile (/= '/') $ stripScheme $ r $ tm LoginR+ memail <- lift $ checkAssertion audience assertion (authHttpManager master) case memail of- Nothing -> error "Invalid assertion"+ Nothing -> liftIO $ throwIO InvalidBrowserIDAssertion Just email -> setCreds True Creds { credsPlugin = pid , credsIdent = email
Yesod/Auth/Email.hs view
@@ -60,7 +60,7 @@ , emailCredsVerkey :: Maybe VerKey } -class (YesodAuth m, SinglePiece (AuthEmailId m)) => YesodAuthEmail m where+class (YesodAuth m, PathPiece (AuthEmailId m)) => YesodAuthEmail m where type AuthEmailId m addUnverified :: Email -> VerKey -> GHandler Auth m (AuthEmailId m)@@ -102,7 +102,7 @@ dispatch "GET" ["register"] = getRegisterR >>= sendResponse dispatch "POST" ["register"] = postRegisterR >>= sendResponse dispatch "GET" ["verify", eid, verkey] =- case fromSinglePiece eid of+ case fromPathPiece eid of Nothing -> notFound Just eid' -> getVerifyR eid' verkey >>= sendResponse dispatch "POST" ["login"] = postLoginR >>= sendResponse@@ -142,7 +142,7 @@ return (lid, key) render <- getUrlRender tm <- getRouteToMaster- let verUrl = render $ tm $ verify (toSinglePiece lid) verKey+ let verUrl = render $ tm $ verify (toPathPiece lid) verKey sendVerifyEmail email verKey verUrl defaultLayout $ do setTitleI Msg.ConfirmationEmailSentTitle@@ -163,7 +163,7 @@ setCreds False $ Creds "email" email [("verifiedEmail", email)] -- FIXME uid? toMaster <- getRouteToMaster setMessageI Msg.AddressVerified- redirect RedirectTemporary $ toMaster setpassR+ redirect $ toMaster setpassR _ -> return () defaultLayout $ do setTitleI Msg.InvalidKey@@ -193,7 +193,7 @@ Nothing -> do setMessageI Msg.InvalidEmailPass toMaster <- getRouteToMaster- redirect RedirectTemporary $ toMaster LoginR+ redirect $ toMaster LoginR getPasswordR :: YesodAuthEmail master => GHandler Auth master RepHtml getPasswordR = do@@ -203,7 +203,7 @@ Just _ -> return () Nothing -> do setMessageI Msg.BadSetPass- redirect RedirectTemporary $ toMaster LoginR+ redirect $ toMaster LoginR defaultLayout $ do setTitleI Msg.SetPassTitle addWidget@@ -233,17 +233,17 @@ y <- getYesod when (new /= confirm) $ do setMessageI Msg.PassMismatch- redirect RedirectTemporary $ toMaster setpassR+ redirect $ toMaster setpassR maid <- maybeAuthId aid <- case maid of Nothing -> do setMessageI Msg.BadSetPass- redirect RedirectTemporary $ toMaster LoginR+ redirect $ toMaster LoginR Just aid -> return aid salted <- liftIO $ saltPass new setPassword aid salted setMessageI Msg.PassUpdated- redirect RedirectTemporary $ loginDest y+ redirect $ loginDest y saltLength :: Int saltLength = 5
− Yesod/Auth/Facebook.hs
@@ -1,123 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-module Yesod.Auth.Facebook- ( authFacebook- , facebookLogin- , facebookUrl- , facebookLogout- , getFacebookAccessToken- ) where--#include "qq.h"--import Yesod.Auth-import qualified Web.Authenticate.Facebook as Facebook-import Data.Aeson-import Data.Aeson.Types (parseMaybe)-import Data.Maybe (fromMaybe)--import Yesod.Form-import Yesod.Handler-import Yesod.Widget-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Trans.Class (lift)-import Data.Text (Text)-import Control.Monad (liftM, mzero, when)-import Data.Monoid (mappend)-import qualified Data.Aeson.Types-import qualified Yesod.Auth.Message as Msg---- | Route for login using this authentication plugin.-facebookLogin :: AuthRoute-facebookLogin = PluginR "facebook" ["forward"]---- | This is just a synonym of 'facebookLogin'. Deprecated since--- @yesod-auth 0.7.8@, please use 'facebookLogin' instead.-facebookUrl :: AuthRoute-facebookUrl = facebookLogin-{-# DEPRECATED facebookUrl "Please use facebookLogin instead." #-}---- | Route for logout using this authentication plugin. Per--- Facebook's policies--- (<https://developers.facebook.com/policy/>), the user needs to--- logout from Facebook itself as well.-facebookLogout :: AuthRoute-facebookLogout = PluginR "facebook" ["logout"]---- | Get Facebook's access token from the session. Returns--- @Nothing@ if it's not found (probably because the user is not--- logged in via Facebook). Note that the returned access token--- may have expired.-getFacebookAccessToken :: MonadIO mo => GGHandler sub master mo (Maybe Facebook.AccessToken)-getFacebookAccessToken =- liftM (fmap Facebook.AccessToken) (lookupSession facebookAccessTokenKey)---- | Key used to store Facebook's access token in the client--- session.-facebookAccessTokenKey :: Text-facebookAccessTokenKey = "_FB"---- | Authentication plugin using Facebook.-authFacebook :: YesodAuth m- => Text -- ^ Application ID- -> Text -- ^ Application secret- -> [Text] -- ^ Requested permissions- -> AuthPlugin m-authFacebook cid secret perms =- AuthPlugin "facebook" dispatch login- where- url = PluginR "facebook" []- dispatch "GET" ["forward"] = do- tm <- getRouteToMaster- render <- getUrlRender- let fb = Facebook.Facebook cid secret $ render $ tm url- redirectText RedirectTemporary $ Facebook.getForwardUrl fb perms- dispatch "GET" [] = do- render <- getUrlRender- tm <- getRouteToMaster- let fb = Facebook.Facebook cid secret $ render $ tm url- code <- runInputGet $ ireq textField "code"- at <- liftIO $ Facebook.getAccessToken fb code- let Facebook.AccessToken at' = at- setSession facebookAccessTokenKey at'- so <- liftIO $ Facebook.getGraphData at "me"- let c = fromMaybe (error "Invalid response from Facebook")- $ parseMaybe (parseCreds at') $ either error id so- setCreds True c- dispatch "GET" ["logout"] = do- m <- getYesod- tm <- getRouteToMaster- mtoken <- getFacebookAccessToken- when (redirectToReferer m) setUltDestReferer- case mtoken of- Nothing -> do- -- Well... then just logout from our app.- redirect RedirectTemporary (tm LogoutR)- Just at -> do- render <- getUrlRender- let logout = Facebook.getLogoutUrl at (render $ tm LogoutR)- redirectText RedirectTemporary logout- dispatch _ _ = notFound- login tm = do- render <- lift getUrlRender- let fb = Facebook.Facebook cid secret $ render $ tm url- let furl = Facebook.getForwardUrl fb $ perms- [QQ(whamlet)|-<p>- <a href="#{furl}">_{Msg.Facebook}-|]--parseCreds :: Text -> Value -> Data.Aeson.Types.Parser (Creds m)-parseCreds at' (Object m) = do- id' <- m .: "id"- let id'' = "http://graph.facebook.com/" `mappend` id'- name <- m .:? "name"- email <- m .:? "email"- return- $ Creds "facebook" id''- $ maybe id (\x -> (:) ("verifiedEmail", x)) email- $ maybe id (\x -> (:) ("displayName ", x)) name- [ ("accessToken", at')- ]-parseCreds _ _ = mzero
Yesod/Auth/GoogleEmail.hs view
@@ -17,7 +17,6 @@ import Yesod.Auth import qualified Web.Authenticate.OpenId as OpenId-import Control.Monad.Attempt import Yesod.Form import Yesod.Handler@@ -27,6 +26,7 @@ import Data.Text (Text) import qualified Yesod.Auth.Message as Msg import qualified Data.Text as T+import Control.Exception.Lifted (try, SomeException) forwardUrl :: AuthRoute forwardUrl = PluginR "googleemail" ["forward"]@@ -41,7 +41,7 @@ [whamlet| <form method=get action=@{tm forwardUrl}> <input type=hidden name=openid_identifier value=https://www.google.com/accounts/o8/id>- <input type=submit value=_{Msg.LoginTitle}>+ <input type=submit value=_{Msg.LoginGoogle}> |] dispatch "GET" ["forward"] = do roid <- runInputGet $ iopt textField name@@ -50,25 +50,26 @@ render <- getUrlRender toMaster <- getRouteToMaster let complete' = render $ toMaster complete- res <- runAttemptT $ OpenId.getForwardUrl oid complete' Nothing+ master <- getYesod+ eres <- lift $ try $ OpenId.getForwardUrl oid complete' Nothing [ ("openid.ax.type.email", "http://schema.openid.net/contact/email") , ("openid.ns.ax", "http://openid.net/srv/ax/1.0") , ("openid.ns.ax.required", "email") , ("openid.ax.mode", "fetch_request") , ("openid.ax.required", "email") , ("openid.ui.icon", "true")- ]- attempt+ ] (authHttpManager master)+ either (\err -> do- setMessage $ toHtml $ show err- redirect RedirectTemporary $ toMaster LoginR+ setMessage $ toHtml $ show (err :: SomeException)+ redirect $ toMaster LoginR )- (redirectText RedirectTemporary)- res+ redirect+ eres Nothing -> do toMaster <- getRouteToMaster setMessageI Msg.NoOpenID- redirect RedirectTemporary $ toMaster LoginR+ redirect $ toMaster LoginR dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues dispatch "GET" ["complete"] = do rr <- getRequest@@ -81,19 +82,20 @@ completeHelper :: YesodAuth m => [(Text, Text)] -> GHandler Auth m () completeHelper gets' = do- res <- runAttemptT $ OpenId.authenticate gets'+ master <- getYesod+ eres <- lift $ try $ OpenId.authenticate gets' (authHttpManager master) toMaster <- getRouteToMaster let onFailure err = do- setMessage $ toHtml $ show err- redirect RedirectTemporary $ toMaster LoginR+ setMessage $ toHtml $ show (err :: SomeException)+ redirect $ toMaster LoginR let onSuccess (OpenId.Identifier ident, _) = do memail <- lookupGetParam "openid.ext1.value.email" case (memail, "https://www.google.com/accounts/o8/id" `T.isPrefixOf` ident) of (Just email, True) -> setCreds True $ Creds "openid" email [] (_, False) -> do setMessage "Only Google login is supported"- redirect RedirectTemporary $ toMaster LoginR+ redirect $ toMaster LoginR (Nothing, _) -> do setMessage "No email address provided"- redirect RedirectTemporary $ toMaster LoginR- attempt onFailure onSuccess res+ redirect $ toMaster LoginR+ either onFailure onSuccess eres
Yesod/Auth/HashDB.hs view
@@ -59,6 +59,7 @@ ------------------------------------------------------------------------------- module Yesod.Auth.HashDB ( HashDBUser(..)+ , Unique (..) , setPassword -- * Authentification , validateUser@@ -90,7 +91,6 @@ 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@@ -137,7 +137,9 @@ -- the database values. validateUser :: ( YesodPersist yesod , b ~ YesodPersistBackend yesod- , PersistBackend b (GGHandler sub yesod IO)+ , b ~ PersistEntityBackend user+ , PersistStore b (GHandler sub yesod)+ , PersistUnique b (GHandler sub yesod) , PersistEntity user , HashDBUser user ) => @@ -151,7 +153,7 @@ return $ hash == saltedHash salt passwd -- Get user data user <- runDB $ getBy userID- return $ fromMaybe False $ validate . snd =<< user+ return $ fromMaybe False $ validate . entityVal =<< user login :: AuthRoute@@ -162,8 +164,10 @@ -- username (whatever it might be) to unique user ID. postLoginR :: ( YesodAuth y, YesodPersist y , b ~ YesodPersistBackend y+ , b ~ PersistEntityBackend user , HashDBUser user, PersistEntity user- , PersistBackend b (GGHandler Auth y IO))+ , PersistStore b (GHandler Auth y)+ , PersistUnique b (GHandler Auth y)) => (Text -> Maybe (Unique user b)) -> GHandler Auth y () postLoginR uniq = do@@ -177,7 +181,7 @@ then setCreds True $ Creds "hashdb" (fromMaybe "" mu) [] else do setMessage [QQ(shamlet)| Invalid username/password |] toMaster <- getRouteToMaster- redirect RedirectTemporary $ toMaster LoginR+ redirect $ toMaster LoginR -- | A drop in for the getAuthId method of your YesodAuth instance which@@ -186,26 +190,28 @@ , HashDBUser user, PersistEntity user , Key b user ~ AuthId master , b ~ YesodPersistBackend master- , PersistBackend b (GGHandler sub master IO))+ , b ~ PersistEntityBackend user+ , PersistUnique b (GHandler sub master)+ , PersistStore b (GHandler sub master)) => (AuthRoute -> Route master) -- ^ your site's Auth Route -> (Text -> Maybe (Unique user b)) -- ^ gets user ID -> Creds master -- ^ the creds argument -> GHandler sub master (Maybe (AuthId master)) getAuthIdHashDB authR uniq creds = do- muid <- maybeAuth+ muid <- maybeAuthId case muid of -- user already authenticated- Just (uid, _) -> return $ Just uid+ Just uid -> return $ Just uid Nothing -> do x <- case uniq (credsIdent creds) of Nothing -> return Nothing Just u -> runDB (getBy u) case x of -- user exists- Just (uid, _) -> return $ Just uid+ Just (Entity uid _) -> return $ Just uid Nothing -> do setMessage [QQ(shamlet)| User not found |]- redirect RedirectTemporary $ authR LoginR+ redirect $ authR LoginR -- | Prompt for username and password, validate that against a database -- which holds the username and a hash of the password@@ -213,7 +219,9 @@ , HashDBUser user , PersistEntity user , b ~ YesodPersistBackend m- , PersistBackend b (GGHandler Auth m IO))+ , b ~ PersistEntityBackend user+ , PersistStore b (GHandler Auth m)+ , PersistUnique b (GHandler Auth m)) => (Text -> Maybe (Unique user b)) -> AuthPlugin m authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> addHamlet [QQ(hamlet)|@@ -252,8 +260,8 @@ ---------------------------------------------------------------- -- | Generate data base instances for a valid user-share2 (mkPersist sqlSettings) (mkMigrate "migrateUsers")- [QQ(persist)|+share [mkPersist sqlSettings, mkMigrate "migrateUsers"]+ [QQ(persistUpperCase)| User username Text Eq password Text
− Yesod/Auth/Kerberos.hs
@@ -1,118 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE OverloadedStrings #-}--- | In-built kerberos authentication for Yesod.------ Please note that all configuration should have been done--- manually on the machine prior to running the code.------ On linux machines the configuration might be in /etc/krb5.conf.--- It's worth checking if the Kerberos service provider (e.g. your university)--- already provide a complete configuration file.------ Be certain that you can manually login from a shell by typing------ > kinit username------ If you fill in your password and the program returns no error code,--- then your kerberos configuration is setup properly.--- Only then can this module be of any use.-module Yesod.Auth.Kerberos- ( authKerberos,- genericAuthKerberos,- KerberosConfig(..),- defaultKerberosConfig- ) where--#include "qq.h"--import Yesod.Auth-import Web.Authenticate.Kerberos-import Data.Text (Text)-import qualified Data.Text as T-import Text.Hamlet-import Yesod.Handler-import Yesod.Widget-import Control.Monad.IO.Class (liftIO)-import Yesod.Form-import Control.Applicative ((<$>), (<*>))--data KerberosConfig = KerberosConfig {- -- | When a user gives username x, f(x) will be passed to Kerberos- usernameModifier :: Text -> Text- -- | When a user gives username x, f(x) will be passed to Yesod- , identifierModifier :: Text -> Text- }---- | A configuration where the username the user provides is the one passed--- to both kerberos and yesod-defaultKerberosConfig :: KerberosConfig-defaultKerberosConfig = KerberosConfig id id---- | A configurable version of 'authKerberos'-genericAuthKerberos :: YesodAuth m => KerberosConfig -> AuthPlugin m-genericAuthKerberos config = AuthPlugin "kerberos" dispatch $ \tm -> addHamlet- [QQ(hamlet)|- <div id="header">- <h1>Login-- <div id="login">- <form method="post" action="@{tm login}">- <table>- <tr>- <th>Username:- <td>- <input id="x" name="username" autofocus="" required>- <tr>- <th>Password:- <td>- <input type="password" name="password" required>- <tr>- <td> - <td>- <input type="submit" value="Login">-- <script>- if (!("autofocus" in document.createElement("input"))) {- document.getElementById("x").focus();- }-|]- where- dispatch "POST" ["login"] = postLoginR config >>= sendResponse- dispatch _ _ = notFound--login :: AuthRoute-login = PluginR "kerberos" ["login"]---- | Kerberos with 'defaultKerberosConfig'-authKerberos :: YesodAuth m => AuthPlugin m-authKerberos = genericAuthKerberos defaultKerberosConfig---- | Handle the login form-postLoginR :: (YesodAuth y) => KerberosConfig -> GHandler Auth y ()-postLoginR config = do- (mu,mp) <- runInputPost $ (,)- <$> iopt textField "username"- <*> iopt textField "password"-- let errorMessage (message :: Text) = do- setMessage [QQ(shamlet)|Error: #{message}|]- toMaster <- getRouteToMaster- redirect RedirectTemporary $ toMaster LoginR-- case (mu,mp) of- (Nothing, _ ) -> errorMessage "Please fill in your username"- (_ , Nothing) -> errorMessage "Please fill in your password"- (Just u , Just p ) -> do- result <- liftIO $ loginKerberos (usernameModifier config u) p- case result of- Ok -> do- let creds = Creds- { credsIdent = identifierModifier config u- , credsPlugin = "Kerberos"- , credsExtra = []- }- setCreds True creds- kerberosError -> errorMessage (T.pack $ show kerberosError)-
Yesod/Auth/Message.hs view
@@ -39,6 +39,8 @@ | InvalidLogin | NowLoggedIn | LoginTitle+ | PleaseProvideUsername+ | PleaseProvidePassword -- | Defaults to 'englishMessage'. defaultMessage :: AuthMessage -> Text@@ -75,6 +77,8 @@ englishMessage InvalidLogin = "Invalid login" englishMessage NowLoggedIn = "You are now logged in" englishMessage LoginTitle = "Login"+englishMessage PleaseProvideUsername = "Please fill in your username"+englishMessage PleaseProvidePassword = "Please fill in your password" portugueseMessage :: AuthMessage -> Text portugueseMessage NoOpenID = "Nenhum identificador OpenID encontrado"@@ -107,3 +111,5 @@ portugueseMessage InvalidLogin = "Informações de login inválidas" portugueseMessage NowLoggedIn = "Você acaba de entrar no site com sucesso!" portugueseMessage LoginTitle = "Entrar no site"+portugueseMessage PleaseProvideUsername = "Por favor digite seu nome de usuário"+portugueseMessage PleaseProvidePassword = "Por favor digite sua senha"
− Yesod/Auth/OAuth.hs
@@ -1,88 +0,0 @@-{-# LANGUAGE CPP, QuasiQuotes, OverloadedStrings #-}-{-# OPTIONS_GHC -fwarn-unused-imports #-}-module Yesod.Auth.OAuth- ( authOAuth- , oauthUrl- , authTwitter- , twitterUrl- ) where--#include "qq.h"--import Yesod.Auth-import Yesod.Form-import Yesod.Handler-import Yesod.Widget-import Text.Hamlet (shamlet)-import Web.Authenticate.OAuth-import Data.Maybe-import Data.String-import Data.ByteString.Char8 (pack)-import Control.Arrow ((***))-import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.Class (lift)-import Data.Text (Text, unpack)-import Data.Text.Encoding (encodeUtf8, decodeUtf8With)-import Data.Text.Encoding.Error (lenientDecode)-import Data.ByteString (ByteString)-import Control.Applicative ((<$>), (<*>))--oauthUrl :: Text -> AuthRoute-oauthUrl name = PluginR name ["forward"]--authOAuth :: YesodAuth m =>- Text -- ^ Service Name- -> String -- ^ OAuth Parameter Name to use for identify- -> String -- ^ Request URL- -> String -- ^ Access Token URL- -> String -- ^ Authorize URL- -> String -- ^ Consumer Key- -> String -- ^ Consumer Secret- -> AuthPlugin m-authOAuth name ident reqUrl accUrl authUrl key sec = AuthPlugin name dispatch login- where- url = PluginR name []- oauth = OAuth { oauthServerName = unpack name, oauthRequestUri = reqUrl- , oauthAccessTokenUri = accUrl, oauthAuthorizeUri = authUrl- , oauthSignatureMethod = HMACSHA1- , oauthConsumerKey = fromString key, oauthConsumerSecret = fromString sec- , oauthCallback = Nothing- }- dispatch "GET" ["forward"] = do- render <- getUrlRender- tm <- getRouteToMaster- let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url }- tok <- liftIO $ getTemporaryCredential oauth'- redirectText RedirectTemporary (fromString $ authorizeUrl oauth' tok)- dispatch "GET" [] = do- (verifier, oaTok) <- runInputGet $ (,)- <$> ireq textField "oauth_verifier"- <*> ireq textField "oauth_token"- let reqTok = Credential [ ("oauth_verifier", encodeUtf8 verifier), ("oauth_token", encodeUtf8 oaTok)- ] - accTok <- liftIO $ getAccessToken oauth reqTok- let crId = decodeUtf8With lenientDecode $ fromJust $ lookup (pack ident) $ unCredential accTok- creds = Creds name crId $ map (bsToText *** bsToText ) $ unCredential accTok- setCreds True creds- dispatch _ _ = notFound- login tm = do- render <- lift getUrlRender- let oaUrl = render $ tm $ oauthUrl name- addHtml- [QQ(shamlet)| <a href=#{oaUrl}>Login with #{name} |]--authTwitter :: YesodAuth m =>- String -- ^ Consumer Key- -> String -- ^ Consumer Secret- -> AuthPlugin m-authTwitter = authOAuth "twitter"- "screen_name"- "http://twitter.com/oauth/request_token"- "http://twitter.com/oauth/access_token"- "http://twitter.com/oauth/authorize"--twitterUrl :: AuthRoute-twitterUrl = oauthUrl "twitter"--bsToText :: ByteString -> Text-bsToText = decodeUtf8With lenientDecode
Yesod/Auth/OpenId.hs view
@@ -11,7 +11,6 @@ import Yesod.Auth import qualified Web.Authenticate.OpenId as OpenId-import Control.Monad.Attempt import Yesod.Form import Yesod.Handler@@ -19,9 +18,9 @@ import Yesod.Request import Text.Cassius (cassius) import Text.Blaze (toHtml)-import Control.Monad.Trans.Class (lift) import Data.Text (Text) import qualified Yesod.Auth.Message as Msg+import Control.Exception.Lifted (SomeException, try) forwardUrl :: AuthRoute forwardUrl = PluginR "openid" ["forward"]@@ -61,18 +60,17 @@ render <- getUrlRender toMaster <- getRouteToMaster let complete' = render $ toMaster complete- res <- runAttemptT $ OpenId.getForwardUrl oid complete' Nothing extensionFields - attempt- (\err -> do- setMessage $ toHtml $ show err- redirect RedirectTemporary $ toMaster LoginR- )- (redirectText RedirectTemporary)- res+ master <- getYesod+ eres <- lift $ try $ OpenId.getForwardUrl oid complete' Nothing extensionFields (authHttpManager master)+ case eres of+ Left err -> do+ setMessage $ toHtml $ show (err :: SomeException)+ redirect $ toMaster LoginR+ Right x -> redirect x Nothing -> do toMaster <- getRouteToMaster setMessageI Msg.NoOpenID- redirect RedirectTemporary $ toMaster LoginR+ redirect $ toMaster LoginR dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues dispatch "GET" ["complete"] = do rr <- getRequest@@ -85,11 +83,12 @@ completeHelper :: YesodAuth m => [(Text, Text)] -> GHandler Auth m () completeHelper gets' = do- res <- runAttemptT $ OpenId.authenticate gets'+ master <- getYesod+ eres <- lift $ try $ OpenId.authenticate gets' (authHttpManager master) toMaster <- getRouteToMaster let onFailure err = do- setMessage $ toHtml $ show err- redirect RedirectTemporary $ toMaster LoginR+ setMessage $ toHtml $ show (err :: SomeException)+ redirect $ toMaster LoginR let onSuccess (OpenId.Identifier ident, _) = setCreds True $ Creds "openid" ident gets'- attempt onFailure onSuccess res+ either onFailure onSuccess eres
Yesod/Auth/Rpxnow.hs view
@@ -15,7 +15,6 @@ import Yesod.Widget import Yesod.Request import Text.Hamlet (hamlet)-import Control.Monad.IO.Class (liftIO) import Data.Text (pack, unpack) import Control.Arrow ((***)) @@ -38,7 +37,8 @@ token <- case token1 ++ token2 of [] -> invalidArgs ["token: Value not supplied"] x:_ -> return $ unpack x- Rpxnow.Identifier ident extra <- liftIO $ Rpxnow.authenticate apiKey token+ master <- getYesod+ Rpxnow.Identifier ident extra <- lift $ Rpxnow.authenticate apiKey token (authHttpManager master) let creds = Creds "rpxnow" ident $ maybe id (\x -> (:) ("verifiedEmail", x))
yesod-auth.cabal view
@@ -1,5 +1,5 @@ name: yesod-auth-version: 0.7.9+version: 0.8.1 license: BSD3 license-file: LICENSE author: Michael Snoyman, Patrick Brisbin@@ -21,47 +21,44 @@ cpp-options: -DGHC7 else build-depends: base >= 4 && < 4.3- build-depends: authenticate >= 0.10.4 && < 0.11+ build-depends: authenticate >= 1.0 && < 1.1 , bytestring >= 0.9.1.4 && < 0.10- , yesod-core >= 0.9.3.4 && < 0.10- , wai >= 0.4 && < 0.5+ , yesod-core >= 0.10.1 && < 0.11+ , wai >= 1.1 && < 1.2 , template-haskell , pureMD5 >= 2.0 && < 2.2 , random >= 1.0.0.2 && < 1.1- , control-monad-attempt >= 0.3.0 && < 0.4 , text >= 0.7 && < 0.12 , mime-mail >= 0.3 && < 0.5 , blaze-html >= 0.4.1.3 && < 0.5- , yesod-persistent >= 0.2 && < 0.3+ , yesod-persistent >= 0.3.1 && < 0.4 , hamlet >= 0.10 && < 0.11 , shakespeare-css >= 0.10 && < 0.11- , yesod-json >= 0.2 && < 0.3+ , yesod-json >= 0.3.1 && < 0.4 , containers , unordered-containers- , yesod-form >= 0.3 && < 0.4+ , yesod-form >= 0.4.1 && < 0.5 , transformers >= 0.2.2 && < 0.3- , persistent >= 0.6 && < 0.7- , persistent-template >= 0.6 && < 0.7+ , persistent >= 0.8 && < 0.9+ , persistent-template >= 0.8 && < 0.9 , SHA >= 1.4.1.3 && < 1.6- , http-enumerator >= 0.6 && < 0.8- , aeson >= 0.3+ , http-conduit >= 1.2.5 && < 1.3+ , aeson >= 0.5 , pwstore-fast >= 2.2 && < 3+ , lifted-base >= 0.1 && < 0.2 exposed-modules: Yesod.Auth Yesod.Auth.BrowserId Yesod.Auth.Dummy Yesod.Auth.Email- Yesod.Auth.Facebook Yesod.Auth.OpenId- Yesod.Auth.OAuth Yesod.Auth.Rpxnow Yesod.Auth.HashDB Yesod.Auth.Message- Yesod.Auth.Kerberos Yesod.Auth.GoogleEmail ghc-options: -Wall include-dirs: include source-repository head type: git- location: git://github.com/yesodweb/yesod.git+ location: https://github.com/yesodweb/yesod