yesod-auth 0.6.0 → 0.6.1
raw patch · 11 files changed
+220/−211 lines, 11 filesdep +pwstore-fastdep ~yesod-core
Dependencies added: pwstore-fast
Dependency ranges changed: yesod-core
Files
- Yesod/Auth.hs +35/−52
- Yesod/Auth/Dummy.hs +3/−5
- Yesod/Auth/Email.hs +19/−34
- Yesod/Auth/Facebook.hs +3/−5
- Yesod/Auth/HashDB.hs +134/−90
- Yesod/Auth/Message.hs +0/−1
- Yesod/Auth/OAuth.hs +4/−7
- Yesod/Auth/OpenId.hs +4/−10
- Yesod/Auth/Rpxnow.hs +3/−5
- include/qq.h +10/−0
- yesod-auth.cabal +5/−2
Yesod/Auth.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Yesod.Auth ( -- * Subsite Auth@@ -22,19 +23,27 @@ , requireAuth ) where -import Yesod.Core-import Yesod.Persist-import Yesod.Json-import Language.Haskell.TH.Syntax hiding (lift)-import qualified Network.Wai as W-import Text.Hamlet (hamlet)-import qualified Data.Map as Map-import Control.Monad.Trans.Class (lift)+#include "qq.h"++import Control.Monad (when) +import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Maybe+ import Data.Aeson-import Data.Text (Text)-import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Map as Map++import Language.Haskell.TH.Syntax hiding (lift)++import qualified Network.Wai as W+import Text.Hamlet (hamlet)++import Yesod.Core+import Yesod.Persist+import Yesod.Json import Yesod.Auth.Message (AuthMessage, defaultMessage) import qualified Yesod.Auth.Message as Msg import Yesod.Form (FormMessage)@@ -91,11 +100,7 @@ [ ClassP ''YesodAuth [VarT $ mkName "master"] ] #define STRINGS *Texts-#if GHC7- [parseRoutes|-#else- [$parseRoutes|-#endif+ [QQ(parseRoutes)| /check CheckR GET /login LoginR GET /logout LogoutR GET POST@@ -108,34 +113,21 @@ -- | FIXME: won't show up till redirect setCreds :: YesodAuth m => Bool -> Creds m -> GHandler s m () setCreds doRedirects creds = do- y <- getYesod+ y <- getYesod maid <- getAuthId creds case maid of Nothing ->- if doRedirects- then do- case authRoute y of- Nothing -> do- rh <- defaultLayout-#if GHC7- [hamlet|-#else- [$hamlet|-#endif- <h1>Invalid login-|]+ when doRedirects $ do+ case authRoute y of+ Nothing -> do rh <- defaultLayout [QQ(hamlet)| <h1>Invalid login |] sendResponse rh- Just ar -> do- setMessageI Msg.InvalidLogin+ Just ar -> do setMessageI Msg.InvalidLogin redirect RedirectTemporary ar- else return () Just aid -> do setSession credsKey $ toSinglePiece aid- if doRedirects- then do- setMessageI Msg.NowLoggedIn- redirectUltDest RedirectTemporary $ loginDest y- else return ()+ when doRedirects $ do+ setMessageI Msg.NowLoggedIn+ redirectUltDest RedirectTemporary $ loginDest y getCheckR :: YesodAuth m => GHandler Auth m RepHtmlJson getCheckR = do@@ -145,11 +137,7 @@ addHtml $ html creds) (json' creds) where html creds =-#if GHC7- [hamlet|-#else- [$hamlet|-#endif+ [QQ(hamlet)| <h1>Authentication Status $maybe _ <- creds <p>Logged in.@@ -162,10 +150,10 @@ ] getLoginR :: YesodAuth m => GHandler Auth m RepHtml-getLoginR = loginHandler+getLoginR = setUltDestReferer >> loginHandler getLogoutR :: YesodAuth m => GHandler Auth m ()-getLogoutR = postLogoutR -- FIXME redirect to post+getLogoutR = setUltDestReferer >> postLogoutR -- FIXME redirect to post postLogoutR :: YesodAuth m => GHandler Auth m () postLogoutR = do@@ -195,15 +183,10 @@ , PersistEntity val , YesodPersist m ) => GHandler s m (Maybe (Key val, val))-maybeAuth = do- maid <- maybeAuthId- case maid of- Nothing -> return Nothing- Just aid -> do- ma <- runDB $ get aid- case ma of- Nothing -> return Nothing- Just a -> return $ Just (aid, a)+maybeAuth = runMaybeT $ do+ aid <- MaybeT $ maybeAuthId+ a <- MaybeT $ runDB $ get aid+ return (aid, a) requireAuthId :: YesodAuth m => GHandler s m (AuthId m) requireAuthId = maybeAuthId >>= maybe redirectLogin return
Yesod/Auth/Dummy.hs view
@@ -8,6 +8,8 @@ ( authDummy ) where +#include "qq.h"+ import Yesod.Auth import Yesod.Form (runInputPost, textField, ireq) import Yesod.Handler (notFound)@@ -23,11 +25,7 @@ dispatch _ _ = notFound url = PluginR "dummy" [] login authToMaster =-#if GHC7- [hamlet|-#else- [$hamlet|-#endif+ [QQ(hamlet)| <form method="post" action="@{authToMaster url}"> \Your new identifier is: <input type="text" name="ident">
Yesod/Auth/Email.hs view
@@ -14,6 +14,8 @@ , setpassR ) where +#include "qq.h"+ import Network.Mail.Mime (randomString) import Yesod.Auth import System.Random@@ -24,6 +26,8 @@ import qualified Data.Text as TS import Data.Text.Lazy.Encoding (encodeUtf8) import Data.Text (Text)+import qualified Crypto.PasswordStore as PS+import qualified Data.Text.Encoding as DTE import Yesod.Form import Yesod.Handler@@ -81,11 +85,7 @@ AuthPlugin "email" dispatch $ \tm -> do y <- lift getYesod l <- lift languages-#if GHC7- [whamlet|-#else- [$whamlet|-#endif+ [QQ(whamlet)| <form method="post" action="@{tm loginR}"> <table> <tr>@@ -119,11 +119,7 @@ defaultLayout $ do setTitleI Msg.RegisterLong addWidget-#if GHC7- [whamlet|-#else- [$whamlet|-#endif+ [QQ(whamlet)| <p>_{Msg.EnterEmail} <form method="post" action="@{toMaster registerR}"> <label for="email">_{Msg.Email}@@ -154,13 +150,7 @@ defaultLayout $ do setTitleI Msg.ConfirmationEmailSentTitle addWidget-#if GHC7- [whamlet|-#else- [$whamlet|-#endif-<p>_{Msg.ConfirmationEmailSent email}-|]+ [QQ(whamlet)| <p>_{Msg.ConfirmationEmailSent email} |] getVerifyR :: YesodAuthEmail m => AuthEmailId m -> Text -> GHandler Auth m RepHtml@@ -181,13 +171,7 @@ defaultLayout $ do setTitleI Msg.InvalidKey addWidget-#if GHC7- [whamlet|-#else- [$whamlet|-#endif-<p>_{Msg.InvalidKey}-|]+ [QQ(whamlet)| <p>_{Msg.InvalidKey} |] postLoginR :: YesodAuthEmail master => GHandler Auth master () postLoginR = do@@ -226,11 +210,7 @@ defaultLayout $ do setTitleI Msg.SetPassTitle addWidget-#if GHC7- [whamlet|-#else- [$whamlet|-#endif+ [QQ(whamlet)| <h3>_{Msg.SetPass} <form method="post" action="@{toMaster setpassR}"> <table>@@ -273,10 +253,9 @@ -- | Salt a password with a randomly generated salt. saltPass :: Text -> IO Text-saltPass pass = do- stdgen <- newStdGen- let salt = take saltLength $ randomRs ('A', 'Z') stdgen- return $ TS.pack $ saltPass' salt $ TS.unpack pass+saltPass = fmap DTE.decodeUtf8+ . flip PS.makePassword 12+ . DTE.encodeUtf8 saltPass' :: String -> String -> String saltPass' salt pass =@@ -287,7 +266,13 @@ isValidPass :: Text -- ^ cleartext password -> SaltedPass -- ^ salted password -> Bool-isValidPass clear' salted' =+isValidPass ct salted =+ PS.verifyPassword (DTE.encodeUtf8 ct) (DTE.encodeUtf8 salted) || isValidPass' ct salted++isValidPass' :: Text -- ^ cleartext password+ -> SaltedPass -- ^ salted password+ -> Bool+isValidPass' clear' salted' = let salt = take saltLength salted in salted == saltPass' salt clear where
Yesod/Auth/Facebook.hs view
@@ -6,6 +6,8 @@ , facebookUrl ) where +#include "qq.h"+ import Yesod.Auth import qualified Web.Authenticate.Facebook as Facebook import Data.Aeson@@ -56,11 +58,7 @@ render <- lift getUrlRender let fb = Facebook.Facebook cid secret $ render $ tm url let furl = Facebook.getForwardUrl fb $ perms-#if GHC7- [whamlet|-#else- [$whamlet|-#endif+ [QQ(whamlet)| <p> <a href="#{furl}">_{Msg.Facebook} |]
Yesod/Auth/HashDB.hs view
@@ -16,8 +16,7 @@ -- Portability : Portable -- -- A yesod-auth AuthPlugin designed to look users up in Persist where--- their user id's and a sha1 hash of their password will already be--- stored.+-- their user id's and a salted SHA1 hash of their password is stored. -- -- Example usage: --@@ -37,10 +36,8 @@ -- > -- > loginDest _ = RootR -- > logoutDest _ = RootR--- > getAuthId = getAuthIdHashDB AuthR --- > showAuthId _ = showIntegral--- > readAuthId _ = readIntegral--- > authPlugins = [authHashDB]+-- > getAuthId = getAuthIdHashDB AuthR (Just . UniqueUser)+-- > authPlugins = [authHashDB (Just . UniqueUser)] -- > -- > -- > -- include the migration function in site startup@@ -49,21 +46,31 @@ -- > runSqlPool (runMigration migrateUsers) p -- > let h = DevSite p ----- Your app must be an instance of YesodPersist and the username and--- hashed-passwords must be added manually to the database.+-- Note that function which converts username to unique identifier must be same. ----- > echo -n 'MyPassword' | sha1sum+-- Your app must be an instance of YesodPersist. and the username,+-- salt and hashed-passwords should be added to the database. --+-- > echo -n 'MySaltMyPassword' | sha1sum+-- -- can be used to get the hash from the commandline. -- ------------------------------------------------------------------------------- module Yesod.Auth.HashDB- ( authHashDB+ ( HashDBUser(..)+ , setPassword+ -- * Authentification+ , validateUser+ , authHashDB , getAuthIdHashDB+ -- * Predefined data type+ , User(..) , UserId , migrateUsers ) where +#include "qq.h"+ import Yesod.Persist import Yesod.Handler import Yesod.Form@@ -71,115 +78,130 @@ import Text.Hamlet (hamlet) import Control.Applicative ((<$>), (<*>))-import Data.ByteString.Lazy.Char8 (pack)+import Control.Monad (replicateM,liftM)+import Control.Monad.IO.Class (MonadIO, liftIO)++import qualified Data.ByteString.Lazy.Char8 as BS (pack) import Data.Digest.Pure.SHA (sha1, showDigest)-import Data.Text (Text, unpack)+import Data.Text (Text, pack, unpack, append) import Data.Maybe (fromMaybe)+import System.Random (randomRIO) --- | Computer the sha1 of a string and return it as a string-sha1String :: String -> String-sha1String = showDigest . sha1 . pack --- | Generate data base instances for a valid user-share2 mkPersist (mkMigrate "migrateUsers")-#if GHC7- [persist|-#else- [$persist|-#endif-User- username Text Eq- password Text- UniqueUser username-|]+-- | Interface for data type which holds user info. It's just a+-- collection of getters and setters+class HashDBUser user where+ -- | Retrieve password hash from user data+ userPasswordHash :: user -> Maybe Text+ -- | Retrieve salt for password+ userPasswordSalt :: user -> Maybe Text+ -- | Set hash and password+ setUserHashAndSalt :: Text -- ^ Salt+ -> Text -- ^ Password hash+ -> user -> user --- | Given a (user,password) in plaintext, validate them against the--- database values-validateUser :: (YesodPersist y, - PersistBackend (YesodDB y (GGHandler sub y IO))) - => (Text, Text) - -> GHandler sub y Bool-validateUser (user,password) = runDB (getBy $ UniqueUser user) >>= \dbUser ->- case dbUser of- -- user not found- Nothing -> return False- -- validate password- Just (_, sqlUser) -> return $ sha1String (unpack password) == unpack (userPassword sqlUser)+-- | Generate random salt. Length of 8 is chosen arbitrarily+randomSalt :: MonadIO m => m Text+randomSalt = pack `liftM` liftIO (replicateM 8 (randomRIO ('0','z'))) +-- | Calculate salted hash using SHA1.+saltedHash :: Text -- ^ Salt+ -> Text -- ^ Password+ -> Text+saltedHash salt = + pack . showDigest . sha1 . BS.pack . unpack . append salt++-- | Set password for user. This function should be used for setting+-- passwords. It generates random salt and calculates proper hashes.+setPassword :: (MonadIO m, HashDBUser user) => Text -> user -> m user+setPassword pwd u = do salt <- randomSalt+ return $ setUserHashAndSalt salt (saltedHash salt pwd) u+++----------------------------------------------------------------+-- Authentification+----------------------------------------------------------------++-- | Given a user ID and password in plaintext, validate them against+-- the database values.+validateUser :: ( YesodPersist yesod+ , PersistBackend (YesodDB yesod (GGHandler sub yesod IO))+ , PersistEntity user+ , HashDBUser user+ ) => + Unique user -- ^ User unique identifier+ -> Text -- ^ Password in plaint-text+ -> GHandler sub yesod Bool+validateUser userID passwd = do+ -- Checks that hash and password match+ let validate u = do hash <- userPasswordHash u+ salt <- userPasswordSalt u+ return $ hash == saltedHash salt passwd+ -- Get user data+ user <- runDB $ getBy userID+ return $ fromMaybe False $ validate . snd =<< user++ login :: AuthRoute login = PluginR "hashdb" ["login"] --- | Handle the login form-postLoginR :: (YesodAuth y,- YesodPersist y, - PersistBackend (YesodDB y (GGHandler Auth y IO)))- => GHandler Auth y ()-postLoginR = do++-- | Handle the login form. First parameter is function which maps+-- username (whatever it might be) to unique user ID.+postLoginR :: ( YesodAuth y, YesodPersist y+ , HashDBUser user, PersistEntity user+ , PersistBackend (YesodDB y (GGHandler Auth y IO))) + => (Text -> Maybe (Unique user)) + -> GHandler Auth y ()+postLoginR uniq = do (mu,mp) <- runInputPost $ (,) <$> iopt textField "username" <*> iopt textField "password" - isValid <- case (mu,mp) of- (Nothing, _ ) -> return False- (_ , Nothing) -> return False- (Just u , Just p ) -> validateUser (u,p)+ isValid <- fromMaybe (return False) + (validateUser <$> (uniq =<< mu) <*> mp)+ if isValid + then setCreds True $ Creds "hashdb" (fromMaybe "" mu) []+ else do setMessage [QQ(hamlet)| Invalid username/password |]+ toMaster <- getRouteToMaster+ redirect RedirectTemporary $ toMaster LoginR - if isValid- then setCreds True $ Creds "hashdb" (fromMaybe "" mu) []- else do- setMessage-#if GHC7- [hamlet|-#else- [$hamlet|-#endif- Invalid username/password-|]- toMaster <- getRouteToMaster- redirect RedirectTemporary $ toMaster LoginR -- | A drop in for the getAuthId method of your YesodAuth instance which -- can be used if authHashDB is the only plugin in use.-getAuthIdHashDB :: (Key User ~ AuthId master,- PersistBackend (YesodDB master (GGHandler sub master IO)),- YesodPersist master,- YesodAuth master)- => (AuthRoute -> Route master) -- ^ your site's Auth Route- -> Creds m -- ^ the creds argument- -> GHandler sub master (Maybe UserId)-getAuthIdHashDB authR creds = do+getAuthIdHashDB :: ( YesodAuth master, YesodPersist master+ , HashDBUser user, PersistEntity user+ , Key user ~ AuthId master+ , PersistBackend (YesodDB master (GGHandler sub master IO)))+ => (AuthRoute -> Route master) -- ^ your site's Auth Route+ -> (Text -> Maybe (Unique user)) -- ^ gets user ID+ -> Creds master -- ^ the creds argument+ -> GHandler sub master (Maybe (AuthId master))+getAuthIdHashDB authR uniq creds = do muid <- maybeAuth case muid of -- user already authenticated Just (uid, _) -> return $ Just uid Nothing -> do- x <- runDB $ getBy $ UniqueUser (credsIdent creds)+ x <- case uniq (credsIdent creds) of+ Nothing -> return Nothing+ Just u -> runDB (getBy u) case x of -- user exists Just (uid, _) -> return $ Just uid Nothing -> do- setMessage-#if GHC7- [hamlet|-#else- [$hamlet|-#endif- User not found-|]+ setMessage [QQ(hamlet)| User not found |] redirect RedirectTemporary $ authR LoginR -- | Prompt for username and password, validate that against a database -- which holds the username and a hash of the password-authHashDB :: (YesodAuth y,- YesodPersist y, - PersistBackend (YesodDB y (GGHandler Auth y IO)))- => AuthPlugin y-authHashDB = AuthPlugin "hashdb" dispatch $ \tm ->-#if GHC7- [hamlet|-#else- [$hamlet|-#endif+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 ->+ [QQ(hamlet)| <div id="header"> <h1>Login @@ -206,5 +228,27 @@ |] where- dispatch "POST" ["login"] = postLoginR >>= sendResponse+ dispatch "POST" ["login"] = postLoginR uniq >>= sendResponse dispatch _ _ = notFound+++----------------------------------------------------------------+-- Predefined datatype+----------------------------------------------------------------++-- | Generate data base instances for a valid user+share2 mkPersist (mkMigrate "migrateUsers")+ [QQ(persist)|+User+ username Text Eq+ password Text+ salt Text+ UniqueUser username+|]++instance HashDBUser User where+ userPasswordHash = Just . userPassword+ userPasswordSalt = Just . userSalt+ setUserHashAndSalt s h u = u { userSalt = s+ , userPassword = h+ }
Yesod/Auth/Message.hs view
@@ -4,7 +4,6 @@ , defaultMessage ) where -import Text.Blaze (Html, toHtml) import Data.Monoid (mappend) import Data.Text (Text)
Yesod/Auth/OAuth.hs view
@@ -6,6 +6,9 @@ , authTwitter , twitterUrl ) where++#include "qq.h"+ import Yesod.Auth import Yesod.Form import Yesod.Handler@@ -66,13 +69,7 @@ render <- lift getUrlRender let oaUrl = render $ tm $ oauthUrl name addHtml-#if GHC7- [hamlet|-#else- [$hamlet|-#endif- <a href=#{oaUrl}>Login with #{name}- |]+ [QQ(hamlet)| <a href=#{oaUrl}>Login with #{name} |] authTwitter :: YesodAuth m => String -- ^ Consumer Key
Yesod/Auth/OpenId.hs view
@@ -6,6 +6,8 @@ , forwardUrl ) where +#include "qq.h"+ import Yesod.Auth import qualified Web.Authenticate.OpenId as OpenId import Control.Monad.Attempt@@ -34,20 +36,12 @@ ident <- lift newIdent y <- lift getYesod addCassius-#if GHC7- [cassius|##{ident}-#else- [$cassius|##{ident}-#endif+ [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-#if GHC7- [whamlet|-#else- [$whamlet|-#endif+ [QQ(whamlet)| <form method="get" action="@{tm forwardUrl}"> <label for="#{ident}">OpenID: # <input id="#{ident}" type="text" name="#{name}" value="http://">
Yesod/Auth/Rpxnow.hs view
@@ -5,6 +5,8 @@ ( authRpxnow ) where +#include "qq.h"+ import Yesod.Auth import qualified Web.Authenticate.Rpxnow as Rpxnow import Control.Monad (mplus)@@ -27,11 +29,7 @@ login tm = do let url = {- FIXME urlEncode $ -} tm $ PluginR "rpxnow" [] addHamlet-#if GHC7- [hamlet|-#else- [$hamlet|-#endif+ [QQ(hamlet)| <iframe src="http://#{app}.rpxnow.com/openid/embed?token_url=@{url}" scrolling="no" frameBorder="no" allowtransparency="true" style="width:400px;height:240px"> |] dispatch _ [] = do
+ include/qq.h view
@@ -0,0 +1,10 @@++-- CPP macro which choses which quasyquotes syntax to use depending+-- on GHC version.+--+-- QQ stands for quasyquote.+#if GHC7+# define QQ(x) x+#else+# define QQ(x) $x+#endif
yesod-auth.cabal view
@@ -1,5 +1,5 @@ name: yesod-auth-version: 0.6.0+version: 0.6.1 license: BSD3 license-file: LICENSE author: Michael Snoyman, Patrick Brisbin@@ -10,6 +10,7 @@ cabal-version: >= 1.6.0 build-type: Simple homepage: http://www.yesodweb.com/+extra-source-files: include/qq.h flag ghc7 @@ -21,7 +22,7 @@ build-depends: base >= 4 && < 4.3 build-depends: authenticate >= 0.9 && < 0.10 , bytestring >= 0.9.1.4 && < 0.10- , yesod-core >= 0.8.1 && < 0.9+ , yesod-core >= 0.8.3 && < 0.9 , wai >= 0.4 && < 0.5 , template-haskell , pureMD5 >= 1.1 && < 2.2@@ -42,6 +43,7 @@ , http-enumerator >= 0.6 && < 0.7 , aeson >= 0.3.2.2 && < 0.4 , web-routes-quasi >= 0.7 && < 0.8+ , pwstore-fast >= 2.1 && < 2.2 exposed-modules: Yesod.Auth Yesod.Auth.Dummy@@ -53,6 +55,7 @@ Yesod.Auth.HashDB Yesod.Auth.Message ghc-options: -Wall+ include-dirs: include source-repository head type: git