yesod-auth 0.6.1.1 → 0.7.1
raw patch · 9 files changed
+223/−51 lines, 9 filesdep +aeson-nativedep +shakespeare-cssdep −aesondep −web-routes-quasidep ~SHAdep ~authenticatedep ~hamlet
Dependencies added: aeson-native, shakespeare-css
Dependencies removed: aeson, web-routes-quasi
Dependency ranges changed: SHA, authenticate, hamlet, persistent, persistent-template, pwstore-fast, yesod-core, yesod-form, yesod-json, yesod-persistent
Files
- Yesod/Auth.hs +13/−11
- Yesod/Auth/BrowserId.hs +48/−0
- Yesod/Auth/Dummy.hs +2/−1
- Yesod/Auth/Email.hs +1/−5
- Yesod/Auth/HashDB.hs +23/−16
- Yesod/Auth/Kerberos.hs +118/−0
- Yesod/Auth/OAuth.hs +2/−2
- Yesod/Auth/OpenId.hs +0/−3
- yesod-auth.cabal +16/−13
Yesod/Auth.hs view
@@ -39,7 +39,7 @@ import Language.Haskell.TH.Syntax hiding (lift) import qualified Network.Wai as W-import Text.Hamlet (hamlet)+import Text.Hamlet (shamlet) import Yesod.Core import Yesod.Persist@@ -119,7 +119,7 @@ Nothing -> when doRedirects $ do case authRoute y of- Nothing -> do rh <- defaultLayout [QQ(hamlet)| <h1>Invalid login |]+ Nothing -> do rh <- defaultLayout $ addHtml [QQ(shamlet)| <h1>Invalid login |] sendResponse rh Just ar -> do setMessageI Msg.InvalidLogin redirect RedirectTemporary ar@@ -134,10 +134,10 @@ creds <- maybeAuthId defaultLayoutJson (do setTitle "Authentication Status"- addHtml $ html creds) (json' creds)+ addHtml $ html' creds) (json' creds) where- html creds =- [QQ(hamlet)|+ html' creds =+ [QQ(shamlet)| <h1>Authentication Status $maybe _ <- creds <p>Logged in.@@ -178,11 +178,12 @@ Just s -> return $ fromSinglePiece s maybeAuth :: ( YesodAuth m- , Key val ~ AuthId m- , PersistBackend (YesodDB m (GGHandler s m IO))+ , b ~ YesodPersistBackend m+ , Key b val ~ AuthId m+ , PersistBackend b (GGHandler s m IO) , PersistEntity val , YesodPersist m- ) => GHandler s m (Maybe (Key val, val))+ ) => GHandler s m (Maybe (Key b val, val)) maybeAuth = runMaybeT $ do aid <- MaybeT $ maybeAuthId a <- MaybeT $ runDB $ get aid@@ -192,11 +193,12 @@ requireAuthId = maybeAuthId >>= maybe redirectLogin return requireAuth :: ( YesodAuth m- , Key val ~ AuthId m- , PersistBackend (YesodDB m (GGHandler s m IO))+ , b ~ YesodPersistBackend m+ , Key b val ~ AuthId m+ , PersistBackend b (GGHandler s m IO) , PersistEntity val , YesodPersist m- ) => GHandler s m (Key val, val)+ ) => GHandler s m (Key b val, val) requireAuth = maybeAuth >>= maybe redirectLogin return redirectLogin :: Yesod m => GHandler s m a
+ Yesod/Auth/BrowserId.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+module Yesod.Auth.BrowserId+ ( authBrowserId+ ) where++import Yesod.Auth+import Web.Authenticate.BrowserId+import Data.Text (Text)+import Yesod.Core+import Text.Hamlet (hamlet)+import Control.Monad.IO.Class (liftIO)++#include "qq.h"++pid :: Text+pid = "browserid"++complete :: AuthRoute+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">+|]+ }
Yesod/Auth/Dummy.hs view
@@ -14,6 +14,7 @@ import Yesod.Form (runInputPost, textField, ireq) import Yesod.Handler (notFound) import Text.Hamlet (hamlet)+import Yesod.Widget (addHamlet) authDummy :: YesodAuth m => AuthPlugin m authDummy =@@ -25,7 +26,7 @@ dispatch _ _ = notFound url = PluginR "dummy" [] login authToMaster =- [QQ(hamlet)|+ addHamlet [QQ(hamlet)| <form method="post" action="@{authToMaster url}"> \Your new identifier is: <input type="text" name="ident">
Yesod/Auth/Email.hs view
@@ -35,8 +35,6 @@ import Yesod.Widget import Yesod.Core import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.Class (lift)-import Web.Routes.Quasi (toSinglePiece, fromSinglePiece) import qualified Yesod.Auth.Message as Msg loginR, registerR, setpassR :: AuthRoute@@ -82,9 +80,7 @@ authEmail :: YesodAuthEmail m => AuthPlugin m authEmail =- AuthPlugin "email" dispatch $ \tm -> do- y <- lift getYesod- l <- lift languages+ AuthPlugin "email" dispatch $ \tm -> [QQ(whamlet)| <form method="post" action="@{tm loginR}"> <table>
Yesod/Auth/HashDB.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GADTs #-} ------------------------------------------------------------------------------- -- | -- Module : Yesod.Auth.HashDB@@ -64,7 +65,8 @@ , authHashDB , getAuthIdHashDB -- * Predefined data type- , User(..)+ , User+ , UserGeneric (..) , UserId , migrateUsers ) where@@ -75,7 +77,8 @@ import Yesod.Handler import Yesod.Form import Yesod.Auth-import Text.Hamlet (hamlet)+import Yesod.Widget (addHamlet)+import Text.Hamlet (hamlet, shamlet) import Control.Applicative ((<$>), (<*>)) import Control.Monad (replicateM,liftM)@@ -125,11 +128,12 @@ -- | Given a user ID and password in plaintext, validate them against -- the database values. validateUser :: ( YesodPersist yesod- , PersistBackend (YesodDB yesod (GGHandler sub yesod IO))+ , b ~ YesodPersistBackend yesod+ , PersistBackend b (GGHandler sub yesod IO) , PersistEntity user , HashDBUser user ) => - Unique user -- ^ User unique identifier+ Unique user b -- ^ User unique identifier -> Text -- ^ Password in plaint-text -> GHandler sub yesod Bool validateUser userID passwd = do@@ -149,9 +153,10 @@ -- | Handle the login form. First parameter is function which maps -- username (whatever it might be) to unique user ID. postLoginR :: ( YesodAuth y, YesodPersist y+ , b ~ YesodPersistBackend y , HashDBUser user, PersistEntity user- , PersistBackend (YesodDB y (GGHandler Auth y IO))) - => (Text -> Maybe (Unique user)) + , PersistBackend b (GGHandler Auth y IO))+ => (Text -> Maybe (Unique user b)) -> GHandler Auth y () postLoginR uniq = do (mu,mp) <- runInputPost $ (,)@@ -162,7 +167,7 @@ (validateUser <$> (uniq =<< mu) <*> mp) if isValid then setCreds True $ Creds "hashdb" (fromMaybe "" mu) []- else do setMessage [QQ(hamlet)| Invalid username/password |]+ else do setMessage [QQ(shamlet)| Invalid username/password |] toMaster <- getRouteToMaster redirect RedirectTemporary $ toMaster LoginR @@ -171,10 +176,11 @@ -- can be used if authHashDB is the only plugin in use. getAuthIdHashDB :: ( YesodAuth master, YesodPersist master , HashDBUser user, PersistEntity user- , Key user ~ AuthId master- , PersistBackend (YesodDB master (GGHandler sub master IO)))+ , Key b user ~ AuthId master+ , b ~ YesodPersistBackend master+ , PersistBackend b (GGHandler sub master IO)) => (AuthRoute -> Route master) -- ^ your site's Auth Route- -> (Text -> Maybe (Unique user)) -- ^ gets user ID+ -> (Text -> Maybe (Unique user b)) -- ^ gets user ID -> Creds master -- ^ the creds argument -> GHandler sub master (Maybe (AuthId master)) getAuthIdHashDB authR uniq creds = do@@ -190,7 +196,7 @@ -- user exists Just (uid, _) -> return $ Just uid Nothing -> do- setMessage [QQ(hamlet)| User not found |]+ setMessage [QQ(shamlet)| User not found |] redirect RedirectTemporary $ authR LoginR -- | Prompt for username and password, validate that against a database@@ -198,9 +204,10 @@ authHashDB :: ( YesodAuth m, YesodPersist m , HashDBUser user , PersistEntity user- , PersistBackend (YesodDB m (GGHandler Auth m IO))) - => (Text -> Maybe (Unique user)) -> AuthPlugin m-authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm ->+ , b ~ YesodPersistBackend m+ , PersistBackend b (GGHandler Auth m IO))+ => (Text -> Maybe (Unique user b)) -> AuthPlugin m+authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> addHamlet [QQ(hamlet)| <div id="header"> <h1>Login@@ -237,7 +244,7 @@ ---------------------------------------------------------------- -- | Generate data base instances for a valid user-share2 mkPersist (mkMigrate "migrateUsers")+share2 (mkPersist sqlSettings) (mkMigrate "migrateUsers") [QQ(persist)| User username Text Eq@@ -246,7 +253,7 @@ UniqueUser username |] -instance HashDBUser User where+instance HashDBUser (UserGeneric backend) where userPasswordHash = Just . userPassword userPasswordSalt = Just . userSalt setUserHashAndSalt s h u = u { userSalt = s
+ Yesod/Auth/Kerberos.hs view
@@ -0,0 +1,118 @@+{-# 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+ [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 [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/OAuth.hs view
@@ -13,7 +13,7 @@ import Yesod.Form import Yesod.Handler import Yesod.Widget-import Text.Hamlet (hamlet)+import Text.Hamlet (shamlet) import Web.Authenticate.OAuth import Data.Maybe import Data.String@@ -69,7 +69,7 @@ render <- lift getUrlRender let oaUrl = render $ tm $ oauthUrl name addHtml- [QQ(hamlet)| <a href=#{oaUrl}>Login with #{name} |]+ [QQ(shamlet)| <a href=#{oaUrl}>Login with #{name} |] authTwitter :: YesodAuth m => String -- ^ Consumer Key
Yesod/Auth/OpenId.hs view
@@ -16,7 +16,6 @@ import Yesod.Handler import Yesod.Widget import Yesod.Request-import Text.Hamlet (hamlet) import Text.Cassius (cassius) import Text.Blaze (toHtml) import Control.Monad.Trans.Class (lift)@@ -34,13 +33,11 @@ name = "openid_identifier" login tm = do ident <- lift newIdent- y <- lift getYesod addCassius [QQ(cassius)|##{ident} background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%; padding-left: 18px; |]- l <- lift languages [QQ(whamlet)| <form method="get" action="@{tm forwardUrl}"> <label for="#{ident}">OpenID: #
yesod-auth.cabal view
@@ -1,5 +1,5 @@ name: yesod-auth-version: 0.6.1.1+version: 0.7.1 license: BSD3 license-file: LICENSE author: Michael Snoyman, Patrick Brisbin@@ -11,6 +11,7 @@ build-type: Simple homepage: http://www.yesodweb.com/ extra-source-files: include/qq.h+description: Authentication for Yesod. flag ghc7 @@ -20,9 +21,9 @@ cpp-options: -DGHC7 else build-depends: base >= 4 && < 4.3- build-depends: authenticate >= 0.9 && < 0.10+ build-depends: authenticate >= 0.10 && < 0.11 , bytestring >= 0.9.1.4 && < 0.10- , yesod-core >= 0.8.3 && < 0.9+ , yesod-core >= 0.9 && < 0.10 , wai >= 0.4 && < 0.5 , template-haskell , pureMD5 >= 1.1 && < 2.2@@ -31,21 +32,22 @@ , text >= 0.7 && < 0.12 , mime-mail >= 0.3 && < 0.4 , blaze-html >= 0.4 && < 0.5- , yesod-persistent >= 0.1 && < 0.2- , hamlet >= 0.8.1 && < 0.9- , yesod-json >= 0.1 && < 0.2+ , yesod-persistent >= 0.2 && < 0.3+ , hamlet >= 0.10 && < 0.11+ , shakespeare-css >= 0.10 && < 0.11+ , yesod-json >= 0.2 && < 0.3 , containers >= 0.2 && < 0.5- , yesod-form >= 0.2 && < 0.3+ , yesod-form >= 0.3 && < 0.4 , transformers >= 0.2 && < 0.3- , persistent >= 0.5 && < 0.6- , persistent-template >= 0.5 && < 0.6- , SHA >= 1.4.1.3 && < 1.5+ , persistent >= 0.6 && < 0.7+ , persistent-template >= 0.6 && < 0.7+ , SHA >= 1.4.1.3 && < 1.6 , http-enumerator >= 0.6 && < 0.7- , aeson >= 0.3.2.2 && < 0.3.2.10- , web-routes-quasi >= 0.7 && < 0.8- , pwstore-fast >= 2.1 && < 2.2+ , aeson-native >= 0.3.2.11 && < 0.4+ , pwstore-fast >= 2.2 && < 3 exposed-modules: Yesod.Auth+ Yesod.Auth.BrowserId Yesod.Auth.Dummy Yesod.Auth.Email Yesod.Auth.Facebook@@ -54,6 +56,7 @@ Yesod.Auth.Rpxnow Yesod.Auth.HashDB Yesod.Auth.Message+ Yesod.Auth.Kerberos ghc-options: -Wall include-dirs: include