diff --git a/Yesod/Auth.hs b/Yesod/Auth.hs --- a/Yesod/Auth.hs +++ b/Yesod/Auth.hs @@ -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)|

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 diff --git a/Yesod/Auth/BrowserId.hs b/Yesod/Auth/BrowserId.hs --- a/Yesod/Auth/BrowserId.hs +++ b/Yesod/Auth/BrowserId.hs @@ -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)| -

- - -|] - } +-- | 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 diff --git a/Yesod/Auth/Email.hs b/Yesod/Auth/Email.hs --- a/Yesod/Auth/Email.hs +++ b/Yesod/Auth/Email.hs @@ -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 diff --git a/Yesod/Auth/Facebook.hs b/Yesod/Auth/Facebook.hs deleted file mode 100644 --- a/Yesod/Auth/Facebook.hs +++ /dev/null @@ -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 --- (), 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)| -

- _{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 diff --git a/Yesod/Auth/GoogleEmail.hs b/Yesod/Auth/GoogleEmail.hs --- a/Yesod/Auth/GoogleEmail.hs +++ b/Yesod/Auth/GoogleEmail.hs @@ -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|

- + |] 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 diff --git a/Yesod/Auth/HashDB.hs b/Yesod/Auth/HashDB.hs --- a/Yesod/Auth/HashDB.hs +++ b/Yesod/Auth/HashDB.hs @@ -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 diff --git a/Yesod/Auth/Kerberos.hs b/Yesod/Auth/Kerberos.hs deleted file mode 100644 --- a/Yesod/Auth/Kerberos.hs +++ /dev/null @@ -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)| -