From 914e0f5acc9a98116bdc8942ecd0b27ee9e601bd Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 28 Sep 2010 14:51:35 +0200 Subject: [PATCH 01/69] first commit --- README | 0 1 file changed, 0 insertions(+), 0 deletions(-) create mode 100644 README diff --git a/README b/README new file mode 100644 index 00000000..e69de29b From 559f9d53d92f104245ce415e7dfe5e93875d2721 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 28 Sep 2010 15:29:41 +0200 Subject: [PATCH 02/69] Initial source pull from Yesod newauth branch --- .gitignore | 4 + LICENSE | 25 ++++ Yesod/Helpers/Auth2.hs | 200 +++++++++++++++++++++++++ Yesod/Helpers/Auth2/Email.hs | 251 ++++++++++++++++++++++++++++++++ Yesod/Helpers/Auth2/Facebook.hs | 51 +++++++ Yesod/Helpers/Auth2/OpenId.hs | 60 ++++++++ Yesod/Helpers/Auth2/Rpxnow.hs | 46 ++++++ auth2.hs | 135 +++++++++++++++++ yesod-auth.cabal | 35 +++++ 9 files changed, 807 insertions(+) create mode 100644 .gitignore create mode 100644 LICENSE create mode 100644 Yesod/Helpers/Auth2.hs create mode 100644 Yesod/Helpers/Auth2/Email.hs create mode 100644 Yesod/Helpers/Auth2/Facebook.hs create mode 100644 Yesod/Helpers/Auth2/OpenId.hs create mode 100644 Yesod/Helpers/Auth2/Rpxnow.hs create mode 100644 auth2.hs create mode 100644 yesod-auth.cabal diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000..d6197881 --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +dist +*.swp +auth2.db3 +client_session_key.aes diff --git a/LICENSE b/LICENSE new file mode 100644 index 00000000..8643e5d8 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2010, Michael Snoyman. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Yesod/Helpers/Auth2.hs b/Yesod/Helpers/Auth2.hs new file mode 100644 index 00000000..6fd574c0 --- /dev/null +++ b/Yesod/Helpers/Auth2.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Yesod.Helpers.Auth2 + ( Auth + , AuthPlugin (..) + , AuthRoute (..) + , getAuth + , Creds (..) + , YesodAuth (..) + , setCreds + , maybeAuthId + , maybeAuth + , requireAuthId + , requireAuth + , authDummy + ) where + +import Yesod +import Language.Haskell.TH.Syntax hiding (lift) +import qualified Data.ByteString.Char8 as S8 +import qualified Network.Wai as W + +data Auth = Auth + +type Method = String +type Piece = String + +data AuthPlugin m = AuthPlugin + { apName :: String + , apDispatch :: Method -> [Piece] -> GHandler Auth m () + , apLogin :: GWidget Auth m () + } + +getAuth :: a -> Auth +getAuth = const Auth + +-- | User credentials +data Creds m = Creds + { credsPlugin :: String -- ^ How the user was authenticated + , credsIdent :: String -- ^ Identifier. Exact meaning depends on plugin. + , credsExtra :: [(String, String)] + } + +class Yesod m => YesodAuth m where + type AuthId m + + -- | Default destination on successful login or logout, if no other + -- destination exists. + defaultDest :: m -> Route m + + getAuthId :: Creds m -> GHandler s m (Maybe (AuthId m)) + + showAuthId :: m -> AuthId m -> String + readAuthId :: m -> String -> Maybe (AuthId m) + + authPlugins :: [AuthPlugin m] + +mkYesodSub "Auth" + [ ClassP ''YesodAuth [VarT $ mkName "master"] + ] [$parseRoutes| +/check CheckR GET +/login LoginR GET +/logout LogoutR GET POST +/page/#String/*Strings PluginR +|] + +credsKey :: String +credsKey = "_ID" + +setCreds :: YesodAuth m => Bool -> Creds m -> GHandler s m () +setCreds doRedirects creds = do + y <- getYesod + maid <- getAuthId creds + case maid of + Nothing -> + if doRedirects + then do + case authRoute y of + Nothing -> do + rh <- defaultLayout $ addBody [$hamlet| +%h1 Invalid login +|] + sendResponse rh + Just ar -> do + setMessage $ string "Invalid login" + redirect RedirectTemporary ar + else return () + Just aid -> do + setSession credsKey $ showAuthId y aid + if doRedirects + then do + setMessage $ string "You are now logged in" + redirect RedirectTemporary $ defaultDest y + else return () + +getCheckR :: YesodAuth m => GHandler Auth m RepHtmlJson +getCheckR = do + creds <- maybeAuthId + defaultLayoutJson (do + setTitle $ string "Authentication Status" + addBody $ html creds) (json creds) + where + html creds = [$hamlet| +%h1 Authentication Status +$maybe creds _ + %p Logged in. +$nothing + %p Not logged in. +|] + json creds = + jsonMap + [ ("logged_in", jsonScalar $ maybe "false" (const "true") creds) + ] + +getLoginR :: YesodAuth m => GHandler Auth m RepHtml +getLoginR = defaultLayout $ do + setTitle $ string "Login" + mapM_ apLogin authPlugins + +getLogoutR :: YesodAuth m => GHandler Auth m () +getLogoutR = postLogoutR -- FIXME redirect to post + +postLogoutR :: YesodAuth m => GHandler Auth m () +postLogoutR = do + y <- getYesod + deleteSession credsKey + redirectUltDest RedirectTemporary $ defaultDest y + +handlePluginR :: YesodAuth m => String -> [String] -> GHandler Auth m () +handlePluginR plugin pieces = do + env <- waiRequest + let method = S8.unpack $ W.requestMethod env + case filter (\x -> apName x == plugin) authPlugins of + [] -> notFound + ap:_ -> apDispatch ap method pieces + +-- | Retrieves user credentials, if user is authenticated. +maybeAuthId :: YesodAuth m => GHandler s m (Maybe (AuthId m)) +maybeAuthId = do + ms <- lookupSession credsKey + y <- getYesod + case ms of + Nothing -> return Nothing + Just s -> return $ readAuthId y s + +maybeAuth :: ( YesodAuth m + , Key val ~ AuthId m + , PersistBackend (YesodDB m (GHandler s m)) + , 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) + +requireAuthId :: YesodAuth m => GHandler s m (AuthId m) +requireAuthId = maybeAuthId >>= maybe redirectLogin return + +requireAuth :: ( YesodAuth m + , Key val ~ AuthId m + , PersistBackend (YesodDB m (GHandler s m)) + , PersistEntity val + , YesodPersist m + ) => GHandler s m (Key val, val) +requireAuth = maybeAuth >>= maybe redirectLogin return + +redirectLogin :: Yesod m => GHandler s m a +redirectLogin = do + y <- getYesod + setUltDest' + case authRoute y of + Just z -> redirect RedirectTemporary z + Nothing -> permissionDenied "Please configure authRoute" + +authDummy :: YesodAuth m => AuthPlugin m +authDummy = + AuthPlugin "dummy" dispatch login + where + dispatch "POST" [] = do + ident <- runFormPost' $ stringInput "ident" + setCreds True $ Creds "dummy" ident [] + dispatch _ _ = notFound + url = PluginR "dummy" [] + authToMaster = liftHandler getRouteToMaster + login = do + tm <- authToMaster + addBody [$hamlet| +%form!method=post!action=@tm.url@ + Your new identifier is: $ + %input!type=text!name=ident + %input!type=submit!value="Dummy Login" +|] diff --git a/Yesod/Helpers/Auth2/Email.hs b/Yesod/Helpers/Auth2/Email.hs new file mode 100644 index 00000000..330b964f --- /dev/null +++ b/Yesod/Helpers/Auth2/Email.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE QuasiQuotes, TypeFamilies #-} +module Yesod.Helpers.Auth2.Email + ( authEmail + , YesodAuthEmail (..) + , EmailCreds (..) + ) where + +import Yesod +import Yesod.Mail (randomString) +import Yesod.Helpers.Auth2 +import System.Random +import Control.Monad (when) +import Control.Applicative ((<$>), (<*>)) +import Data.Digest.Pure.MD5 +import Data.String (fromString) +import qualified Data.ByteString.Lazy.UTF8 as LU + +login, register, setpass :: AuthRoute +login = PluginR "email" ["login"] +register = PluginR "email" ["register"] +setpass = PluginR "email" ["set-password"] + +verify :: String -> String -> AuthRoute -- FIXME +verify eid verkey = PluginR "email" ["verify", eid, verkey] + +type Email = String +type VerKey = String +type VerUrl = String +type SaltedPass = String +type VerStatus = Bool + +-- | Data stored in a database for each e-mail address. +data EmailCreds m = EmailCreds + { emailCredsId :: AuthEmailId m + , emailCredsAuthId :: Maybe (AuthId m) + , emailCredsStatus :: VerStatus + , emailCredsVerkey :: Maybe VerKey + } + +class YesodAuth m => YesodAuthEmail m where + type AuthEmailId m + + showAuthEmailId :: m -> AuthEmailId m -> String + readAuthEmailId :: m -> String -> Maybe (AuthEmailId m) + + addUnverified :: Email -> VerKey -> GHandler Auth m (AuthEmailId m) + sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler Auth m () + getVerifyKey :: AuthEmailId m -> GHandler Auth m (Maybe VerKey) + setVerifyKey :: AuthEmailId m -> VerKey -> GHandler Auth m () + verifyAccount :: AuthEmailId m -> GHandler Auth m (Maybe (AuthId m)) + getPassword :: AuthId m -> GHandler Auth m (Maybe SaltedPass) + setPassword :: AuthId m -> SaltedPass -> GHandler Auth m () + getEmailCreds :: Email -> GHandler Auth m (Maybe (EmailCreds m)) + getEmail :: AuthEmailId m -> GHandler Auth m (Maybe Email) + + -- | Generate a random alphanumeric string. + randomKey :: m -> IO String + randomKey _ = do + stdgen <- newStdGen + return $ fst $ randomString 10 stdgen + +authEmail :: YesodAuthEmail m => AuthPlugin m +authEmail = + AuthPlugin "email" dispatch login' + where + go x = x >>= sendResponse + dispatch "GET" ["register"] = go getRegisterR + dispatch "POST" ["register"] = go postRegisterR + dispatch "GET" ["verify", eid, verkey] = do + y <- getYesod + case readAuthEmailId y eid of + Nothing -> notFound + Just eid' -> go $ getVerifyR eid' verkey + dispatch "POST" ["login"] = go postLoginR + dispatch "GET" ["set-password"] = go getPasswordR + dispatch "POST" ["set-password"] = go postPasswordR + dispatch _ _ = notFound + + login' = do + tm <- liftHandler getRouteToMaster + addBody [$hamlet| +%form!method=post!action=@tm.login@ + %table + %tr + %th E-mail + %td + %input!type=email!name=email + %tr + %th Password + %td + %input!type=password!name=password + %tr + %td!colspan=2 + %input!type=submit!value="Login via email" + %a!href=@tm.register@ I don't have an account +|] + +getRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml +getRegisterR = do + toMaster <- getRouteToMaster + defaultLayout $ do + setTitle $ string "Register a new account" + addBody [$hamlet| +%p Enter your e-mail address below, and a confirmation e-mail will be sent to you. +%form!method=post!action=@toMaster.register@ + %label!for=email E-mail + %input#email!type=email!name=email!width=150 + %input!type=submit!value=Register +|] + +postRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml +postRegisterR = do + y <- getYesod + email <- runFormPost' $ emailInput "email" + mecreds <- getEmailCreds email + (lid, verKey) <- + case mecreds of + Just (EmailCreds lid _ _ (Just key)) -> return (lid, key) + Just (EmailCreds lid _ _ Nothing) -> do + key <- liftIO $ randomKey y + setVerifyKey lid key + return (lid, key) + Nothing -> do + key <- liftIO $ randomKey y + lid <- addUnverified email key + return (lid, key) + render <- getUrlRender + tm <- getRouteToMaster + let verUrl = render $ tm $ verify (showAuthEmailId y lid) verKey + sendVerifyEmail email verKey verUrl + defaultLayout $ do + setTitle $ string "Confirmation e-mail sent" + addBody [$hamlet| +%p A confirmation e-mail has been sent to $email$. +|] + +getVerifyR :: YesodAuthEmail m + => AuthEmailId m -> String -> GHandler Auth m RepHtml +getVerifyR lid key = do + realKey <- getVerifyKey lid + memail <- getEmail lid + case (realKey == Just key, memail) of + (True, Just email) -> do + muid <- verifyAccount lid + case muid of + Nothing -> return () + Just uid -> do + setCreds False $ Creds "email" email [("verifiedEmail", email)] -- FIXME uid? + toMaster <- getRouteToMaster + setMessage $ string "Address verified, please set a new password" + redirect RedirectTemporary $ toMaster setpass + _ -> return () + defaultLayout $ do + setTitle $ string "Invalid verification key" + addBody [$hamlet| +%p I'm sorry, but that was an invalid verification key. +|] + +postLoginR :: YesodAuthEmail master => GHandler Auth master () +postLoginR = do + (email, pass) <- runFormPost' $ (,) + <$> emailInput "email" + <*> stringInput "password" + y <- getYesod + mecreds <- getEmailCreds email + maid <- + case (mecreds >>= emailCredsAuthId, fmap emailCredsStatus mecreds) of + (Just aid, Just True) -> do + mrealpass <- getPassword aid + case mrealpass of + Nothing -> return Nothing + Just realpass -> return $ + if isValidPass pass realpass + then Just aid + else Nothing + _ -> return Nothing + case maid of + Just aid -> + setCreds True $ Creds "email" email [("verifiedEmail", email)] -- FIXME aid? + Nothing -> do + setMessage $ string "Invalid email/password combination" + toMaster <- getRouteToMaster + redirect RedirectTemporary $ toMaster LoginR + +getPasswordR :: YesodAuthEmail master => GHandler Auth master RepHtml +getPasswordR = do + toMaster <- getRouteToMaster + maid <- maybeAuthId + case maid of + Just _ -> return () + Nothing -> do + setMessage $ string "You must be logged in to set a password" + redirect RedirectTemporary $ toMaster login + defaultLayout $ do + setTitle $ string "Set password" + addBody [$hamlet| +%h3 Set a new password +%form!method=post!action=@toMaster.setpass@ + %table + %tr + %th New password + %td + %input!type=password!name=new + %tr + %th Confirm + %td + %input!type=password!name=confirm + %tr + %td!colspan=2 + %input!type=submit!value=Submit +|] + +postPasswordR :: YesodAuthEmail master => GHandler Auth master () +postPasswordR = do + (new, confirm) <- runFormPost' $ (,) + <$> stringInput "new" + <*> stringInput "confirm" + toMaster <- getRouteToMaster + when (new /= confirm) $ do + setMessage $ string "Passwords did not match, please try again" + redirect RedirectTemporary $ toMaster setpass + maid <- maybeAuthId + aid <- case maid of + Nothing -> do + setMessage $ string "You must be logged in to set a password" + redirect RedirectTemporary $ toMaster login + Just aid -> return aid + salted <- liftIO $ saltPass new + setPassword aid salted + setMessage $ string "Password updated" + y <- getYesod + redirect RedirectTemporary $ defaultDest y + +saltLength :: Int +saltLength = 5 + +saltPass :: String -> IO String +saltPass pass = do + stdgen <- newStdGen + let salt = take saltLength $ randomRs ('A', 'Z') stdgen + return $ saltPass' salt pass + +saltPass' :: String -> String -> String +saltPass' salt pass = salt ++ show (md5 $ LU.fromString $ salt ++ pass) + +isValidPass :: String -- ^ cleartext password + -> SaltedPass -- ^ salted password + -> Bool +isValidPass clear salted = + let salt = take saltLength salted + in salted == saltPass' salt clear diff --git a/Yesod/Helpers/Auth2/Facebook.hs b/Yesod/Helpers/Auth2/Facebook.hs new file mode 100644 index 00000000..dd0af3a9 --- /dev/null +++ b/Yesod/Helpers/Auth2/Facebook.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE QuasiQuotes #-} +module Yesod.Helpers.Auth2.Facebook + ( authFacebook + ) where + +import Yesod +import Yesod.Helpers.Auth2 +import qualified Web.Authenticate.Facebook as Facebook +import Data.Object (fromMapping, lookupScalar) +import Data.Maybe (fromMaybe) + +authFacebook :: YesodAuth m + => String -- ^ Application ID + -> String -- ^ Application secret + -> [String] -- ^ Requested permissions + -> AuthPlugin m +authFacebook cid secret perms = + AuthPlugin "facebook" dispatch login + where + url = PluginR "facebook" [] + dispatch "GET" [] = do + render <- getUrlRender + tm <- getRouteToMaster + let fb = Facebook.Facebook cid secret $ render $ tm url + code <- runFormGet' $ stringInput "code" + at <- liftIO $ Facebook.getAccessToken fb code + let Facebook.AccessToken at' = at + so <- liftIO $ Facebook.getGraphData at "me" + let c = fromMaybe (error "Invalid response from Facebook") $ do + m <- fromMapping so + id' <- lookupScalar "id" m + let name = lookupScalar "name" m + let email = lookupScalar "email" m + let id'' = "http://graph.facebook.com/" ++ id' + return + $ Creds "facebook" id'' + $ maybe id (\x -> (:) ("verifiedEmail", x)) email + $ maybe id (\x -> (:) ("displayName ", x)) name + [ ("accessToken", at') + ] + setCreds True c + dispatch _ _ = notFound + login = do + tm <- liftHandler getRouteToMaster + render <- liftHandler getUrlRender + let fb = Facebook.Facebook cid secret $ render $ tm url + let furl = Facebook.getForwardUrl fb $ perms + addBody [$hamlet| +%p + %a!href=$furl$ Login with Facebook +|] diff --git a/Yesod/Helpers/Auth2/OpenId.hs b/Yesod/Helpers/Auth2/OpenId.hs new file mode 100644 index 00000000..369f18bd --- /dev/null +++ b/Yesod/Helpers/Auth2/OpenId.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE QuasiQuotes #-} +module Yesod.Helpers.Auth2.OpenId + ( authOpenId + ) where + +import Yesod +import Yesod.Helpers.Auth2 +import qualified Web.Authenticate.OpenId as OpenId +import Control.Monad.Attempt + +authOpenId :: YesodAuth m => AuthPlugin m +authOpenId = + AuthPlugin "openid" dispatch login + where + forward = PluginR "openid" ["forward"] + complete = PluginR "openid" ["complete"] + name = "openid_identifier" + login = do + tm <- liftHandler getRouteToMaster + addStyle [$cassius| +#openid + background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%; + padding-left: 18px; +|] + addBody [$hamlet| +%form!method=post!action=@tm.forward@ + %label!for=openid OpenID: $ + %input#openid!type=text!name=$name$ + %input!type=submit!value="Login via OpenID" +|] + dispatch "POST" ["forward"] = do + (roid, _, _) <- runFormPost $ stringInput name + case roid of + FormSuccess oid -> do + render <- getUrlRender + toMaster <- getRouteToMaster + let complete' = render $ toMaster complete + res <- runAttemptT $ OpenId.getForwardUrl oid complete' + attempt + (\err -> do + setMessage $ string $ show err + redirect RedirectTemporary $ toMaster LoginR) + (redirectString RedirectTemporary) + res + _ -> do + toMaster <- getRouteToMaster + setMessage $ string "No OpenID identifier found" + redirect RedirectTemporary $ toMaster LoginR + dispatch "GET" ["complete"] = do + rr <- getRequest + let gets' = reqGetParams rr + res <- runAttemptT $ OpenId.authenticate gets' + toMaster <- getRouteToMaster + let onFailure err = do + setMessage $ string $ show err + redirect RedirectTemporary $ toMaster LoginR + let onSuccess (OpenId.Identifier ident) = + setCreds True $ Creds "openid" ident [] + attempt onFailure onSuccess res + dispatch _ _ = notFound diff --git a/Yesod/Helpers/Auth2/Rpxnow.hs b/Yesod/Helpers/Auth2/Rpxnow.hs new file mode 100644 index 00000000..faa127e9 --- /dev/null +++ b/Yesod/Helpers/Auth2/Rpxnow.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE QuasiQuotes #-} +module Yesod.Helpers.Auth2.Rpxnow + ( authRpxnow + ) where + +import Yesod +import Yesod.Helpers.Auth2 +import qualified Web.Authenticate.Rpxnow as Rpxnow +import Control.Monad (mplus) + +authRpxnow :: YesodAuth m + => String -- ^ app name + -> String -- ^ key + -> AuthPlugin m +authRpxnow app apiKey = + AuthPlugin "rpxnow" dispatch login + where + login = do + tm <- liftHandler getRouteToMaster + let url = {- FIXME urlEncode $ -} tm $ PluginR "rpxnow" [] + addBody [$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 + token1 <- lookupGetParam "token" + token2 <- lookupPostParam "token" + let token = case token1 `mplus` token2 of + Nothing -> invalidArgs ["token: Value not supplied"] + Just x -> x + Rpxnow.Identifier ident extra <- liftIO $ Rpxnow.authenticate apiKey token + let creds = + Creds "rpxnow" ident + $ maybe id (\x -> (:) ("verifiedEmail", x)) + (lookup "verifiedEmail" extra) + $ maybe id (\x -> (:) ("displayName", x)) + (getDisplayName extra) + [] + setCreds True creds + dispatch _ _ = notFound + +-- | Get some form of a display name. +getDisplayName :: [(String, String)] -> Maybe String +getDisplayName extra = + foldr (\x -> mplus (lookup x extra)) Nothing choices + where + choices = ["verifiedEmail", "email", "displayName", "preferredUsername"] diff --git a/auth2.hs b/auth2.hs new file mode 100644 index 00000000..6e4ad558 --- /dev/null +++ b/auth2.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +import Yesod +import Yesod.Mail + +import Yesod.Helpers.Auth2 +import Yesod.Helpers.Auth2.OpenId +import Yesod.Helpers.Auth2.Rpxnow +import Yesod.Helpers.Auth2.Facebook +import Yesod.Helpers.Auth2.Email + +import Control.Monad (join) +import Database.Persist.Sqlite +import Safe (readMay) + +mkPersist [$persist| +Email + email String + status Bool update + verkey String null update + password String null update + UniqueEmail email +|] + +data A2 = A2 { connPool :: ConnectionPool } +mkYesod "A2" [$parseRoutes| +/auth AuthR Auth getAuth +|] +instance Yesod A2 where approot _ = "http://localhost:3000" +instance YesodAuth A2 where + type AuthId A2 = String + defaultDest _ = AuthR CheckR + getAuthId = return . Just . credsIdent + showAuthId = const id + readAuthId = const Just + authPlugins = + [ authDummy + , authOpenId + , authRpxnow "yesod-test" "c8043882f14387d7ad8dfc99a1a8dab2e028f690" + , authFacebook + "d790dfc0203e31c0209ed32f90782c31" + "a7685e10c8977f5435e599aaf1d232eb" + [] + , authEmail + ] + +main :: IO () +main = withConnectionPool $ \p -> do + flip runConnectionPool p $ runMigration $ migrate (undefined :: Email) + basicHandler 3000 $ A2 p + +instance YesodAuthEmail A2 where + type AuthEmailId A2 = EmailId + showAuthEmailId _ = show + readAuthEmailId _ = readMay + + addUnverified email verkey = runDB $ insert $ Email email False (Just verkey) Nothing + sendVerifyEmail email verkey verurl = do + render <- getUrlRenderParams + tm <- getRouteToMaster + let lbs = renderHamlet render [$hamlet| +%p + %a!href=$verurl$ Verify your email address. +|] + liftIO $ renderSendMail Mail + { mailHeaders = + [ ("To", email) + , ("From", "reply@orangeroster.com") + , ("Subject", "OrangeRoster: Verify your email address") + ] + , mailPlain = verurl + , mailParts = + [ Part + { partType = "text/html; charset=utf-8" + , partEncoding = None + , partDisposition = Inline + , partContent = lbs + } + ] + } + getVerifyKey emailid = runDB $ do + x <- get $ fromIntegral emailid + return $ maybe Nothing emailVerkey x + setVerifyKey emailid verkey = runDB $ + update (fromIntegral emailid) [EmailVerkey $ Just verkey] + verifyAccount emailid' = runDB $ do + {- FIXME + let emailid = fromIntegral emailid' + x <- get emailid + uid <- + case x of + Nothing -> return Nothing + Just (Email (Just uid) _ _) -> return $ Just uid + Just (Email Nothing email _) -> do + update emailid [EmailStatus True] + return $ Just email + update emailid [EmailVerkey Nothing] + return uid + -} + return Nothing + getPassword _ = return Nothing -- FIXME runDB . fmap (join . fmap emailPassword) . get + setPassword emailid password = runDB $ do + {- FIXME + _x <- get emailid + case x of + Just (Email (Just uid) _ _) -> do + update uid [EmailPassword $ Just password] + update emailid [EmailVerkey Nothing] + _ -> return () + -} + return () + getEmailCreds email = runDB $ do + x <- getBy $ UniqueEmail email + case x of + Nothing -> return Nothing + Just (eid, e) -> + return $ Just EmailCreds + { emailCredsId = fromIntegral eid + , emailCredsAuthId = Just $ emailEmail e + , emailCredsStatus = emailStatus e + , emailCredsVerkey = emailVerkey e + } + getEmail emailid = runDB $ do + x <- get $ fromIntegral emailid + return $ fmap emailEmail x + +instance YesodPersist A2 where + type YesodDB A2 = SqlPersist + runDB db = fmap connPool getYesod >>= runConnectionPool db + +withConnectionPool :: MonadCatchIO m => (ConnectionPool -> m a) -> m a +withConnectionPool = withSqlitePool "auth2.db3" 10 + +runConnectionPool :: MonadCatchIO m => SqlPersist m a -> ConnectionPool -> m a +runConnectionPool = runSqlPool diff --git a/yesod-auth.cabal b/yesod-auth.cabal new file mode 100644 index 00000000..f6baa0dd --- /dev/null +++ b/yesod-auth.cabal @@ -0,0 +1,35 @@ +name: yesod-auth +version: 0.0.0 +license: BSD3 +license-file: LICENSE +author: Michael Snoyman +maintainer: Michael Snoyman +synopsis: Authentication for Yesod. +category: Web +stability: Stable +cabal-version: >= 1.6 +build-type: Simple +homepage: http://docs.yesodweb.com/ + +library + build-depends: base >= 4 && < 5 + , authenticate >= 0.6.4 && < 0.7 + , bytestring >= 0.9.1.4 && < 0.10 + , yesod >= 0.5.1 && < 0.6 + , wai >= 0.2 && < 0.3 + , template-haskell + , pureMD5 >= 1.1 && < 1.2 + , random >= 1.0 && < 1.1 + , data-object >= 0.3.1.3 && < 0.4 + , control-monad-attempt >= 0.3.0 && < 0.4 + , utf8-string >= 0.3.4 && < 0.4 + exposed-modules: Yesod.Helpers.Auth2 + Yesod.Helpers.Auth2.Email + Yesod.Helpers.Auth2.Facebook + Yesod.Helpers.Auth2.OpenId + Yesod.Helpers.Auth2.Rpxnow + ghc-options: -Wall + +source-repository head + type: git + location: git://github.com/snoyberg/yesod.git From 53bc6cfd80c6d45c40df7959e9546302635bb6a5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 28 Sep 2010 15:42:50 +0200 Subject: [PATCH 03/69] Email authentication works in sample --- auth2.hs | 27 ++++++++------------------- 1 file changed, 8 insertions(+), 19 deletions(-) diff --git a/auth2.hs b/auth2.hs index 6e4ad558..54b2e99c 100644 --- a/auth2.hs +++ b/auth2.hs @@ -15,7 +15,7 @@ import Safe (readMay) mkPersist [$persist| Email - email String + email String Eq status Bool update verkey String null update password String null update @@ -84,31 +84,20 @@ instance YesodAuthEmail A2 where setVerifyKey emailid verkey = runDB $ update (fromIntegral emailid) [EmailVerkey $ Just verkey] verifyAccount emailid' = runDB $ do - {- FIXME let emailid = fromIntegral emailid' x <- get emailid uid <- case x of Nothing -> return Nothing - Just (Email (Just uid) _ _) -> return $ Just uid - Just (Email Nothing email _) -> do + Just email -> do update emailid [EmailStatus True] - return $ Just email - update emailid [EmailVerkey Nothing] + return $ Just $ emailEmail email return uid - -} - return Nothing - getPassword _ = return Nothing -- FIXME runDB . fmap (join . fmap emailPassword) . get - setPassword emailid password = runDB $ do - {- FIXME - _x <- get emailid - case x of - Just (Email (Just uid) _ _) -> do - update uid [EmailPassword $ Just password] - update emailid [EmailVerkey Nothing] - _ -> return () - -} - return () + getPassword email = runDB $ do + x <- getBy $ UniqueEmail email + return $ x >>= emailPassword . snd + setPassword email password = runDB $ + updateWhere [EmailEmailEq email] [EmailPassword $ Just password] getEmailCreds email = runDB $ do x <- getBy $ UniqueEmail email case x of From 0fa8280e3d0321be65da9a556606d9d590cc712e Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 3 Oct 2010 10:00:10 +0200 Subject: [PATCH 04/69] OpenID 2 support --- Yesod/Helpers/Auth2/OpenId.hs | 58 ++++++++++++++++++++++++++++++++--- yesod-auth.cabal | 5 +-- 2 files changed, 56 insertions(+), 7 deletions(-) diff --git a/Yesod/Helpers/Auth2/OpenId.hs b/Yesod/Helpers/Auth2/OpenId.hs index 369f18bd..914a2dc0 100644 --- a/Yesod/Helpers/Auth2/OpenId.hs +++ b/Yesod/Helpers/Auth2/OpenId.hs @@ -7,13 +7,15 @@ import Yesod import Yesod.Helpers.Auth2 import qualified Web.Authenticate.OpenId as OpenId import Control.Monad.Attempt +import Network.OpenID authOpenId :: YesodAuth m => AuthPlugin m authOpenId = AuthPlugin "openid" dispatch login where forward = PluginR "openid" ["forward"] - complete = PluginR "openid" ["complete"] + complete1 = PluginR "openid" ["complete1"] + complete2 = PluginR "openid" ["complete2"] name = "openid_identifier" login = do tm <- liftHandler getRouteToMaster @@ -28,25 +30,47 @@ authOpenId = %input#openid!type=text!name=$name$ %input!type=submit!value="Login via OpenID" |] + forward2 complete' oid = do + case normalizeIdentifier $ Identifier oid of + Nothing -> return $ "Unable to normalize identifier: " ++ oid + Just ident -> do + let resolve = liftIO . makeRequest True + rpi <- liftIO $ discover resolve ident + case rpi of + Left err -> return $ "Error on discovery: " ++ show err + Right (p, i) -> do + eam <- liftIO $ associate emptyAssociationMap True resolve p + case eam of + Left err -> return $ "Error on associate: " ++ show err + Right am -> do + let au = authenticationURI am Setup p i complete' Nothing + setSession "OPENID_AM" $ show am + redirectString RedirectTemporary $ show au dispatch "POST" ["forward"] = do (roid, _, _) <- runFormPost $ stringInput name case roid of FormSuccess oid -> do render <- getUrlRender toMaster <- getRouteToMaster - let complete' = render $ toMaster complete + let complete2' = render $ toMaster complete2 + msg <- forward2 complete2' oid + let complete' = render $ toMaster complete1 res <- runAttemptT $ OpenId.getForwardUrl oid complete' attempt (\err -> do - setMessage $ string $ show err - redirect RedirectTemporary $ toMaster LoginR) + setMessage $ string $ unlines + [ show err + , msg + ] + redirect RedirectTemporary $ toMaster LoginR + ) (redirectString RedirectTemporary) res _ -> do toMaster <- getRouteToMaster setMessage $ string "No OpenID identifier found" redirect RedirectTemporary $ toMaster LoginR - dispatch "GET" ["complete"] = do + dispatch "GET" ["complete1"] = do rr <- getRequest let gets' = reqGetParams rr res <- runAttemptT $ OpenId.authenticate gets' @@ -57,4 +81,28 @@ authOpenId = let onSuccess (OpenId.Identifier ident) = setCreds True $ Creds "openid" ident [] attempt onFailure onSuccess res + dispatch "GET" ["complete2"] = do + amString <- lookupSession "OPENID_AM" + deleteSession "OPENID_AM" + params <- reqGetParams `fmap` getRequest + let am = case amString >>= readMay of + Nothing -> emptyAssociationMap + Just x -> x + let resolve = liftIO . makeRequest True + render <- getUrlRender + toMaster <- getRouteToMaster + let complete2' = render $ toMaster complete2 + res <- liftIO $ verifyAuthentication am params complete2' resolve + let mident = lookup "openid.identity" params + case (res, mident) of + (Right (), Just ident) -> + setCreds True $ Creds "openid" ident [] + _ -> do + setMessage $ string "Error logging in via OpenID" + redirect RedirectTemporary $ toMaster LoginR dispatch _ _ = notFound + +readMay :: Read a => String -> Maybe a +readMay s = case reads s of + (x, _):_ -> Just x + [] -> Nothing diff --git a/yesod-auth.cabal b/yesod-auth.cabal index f6baa0dd..8656ac0f 100644 --- a/yesod-auth.cabal +++ b/yesod-auth.cabal @@ -1,5 +1,5 @@ name: yesod-auth -version: 0.0.0 +version: 0.0.1 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -13,7 +13,7 @@ homepage: http://docs.yesodweb.com/ library build-depends: base >= 4 && < 5 - , authenticate >= 0.6.4 && < 0.7 + , authenticate >= 0.6.5 && < 0.7 , bytestring >= 0.9.1.4 && < 0.10 , yesod >= 0.5.1 && < 0.6 , wai >= 0.2 && < 0.3 @@ -23,6 +23,7 @@ library , data-object >= 0.3.1.3 && < 0.4 , control-monad-attempt >= 0.3.0 && < 0.4 , utf8-string >= 0.3.4 && < 0.4 + , openid >= 0.1.7 && < 0.2 exposed-modules: Yesod.Helpers.Auth2 Yesod.Helpers.Auth2.Email Yesod.Helpers.Auth2.Facebook From 0cc763d5b8451c167e45cd09bb86e8d5ed43323f Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 4 Oct 2010 16:50:39 +0200 Subject: [PATCH 05/69] apLogin has existential subsite --- Yesod/Helpers/Auth2.hs | 12 ++++++------ Yesod/Helpers/Auth2/Email.hs | 3 +-- Yesod/Helpers/Auth2/Facebook.hs | 3 +-- Yesod/Helpers/Auth2/OpenId.hs | 3 +-- Yesod/Helpers/Auth2/Rpxnow.hs | 3 +-- yesod-auth.cabal | 2 +- 6 files changed, 11 insertions(+), 15 deletions(-) diff --git a/Yesod/Helpers/Auth2.hs b/Yesod/Helpers/Auth2.hs index 6fd574c0..a3a6cfe6 100644 --- a/Yesod/Helpers/Auth2.hs +++ b/Yesod/Helpers/Auth2.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} module Yesod.Helpers.Auth2 ( Auth , AuthPlugin (..) @@ -30,7 +31,7 @@ type Piece = String data AuthPlugin m = AuthPlugin { apName :: String , apDispatch :: Method -> [Piece] -> GHandler Auth m () - , apLogin :: GWidget Auth m () + , apLogin :: forall s. (Route Auth -> Route m) -> GWidget s m () } getAuth :: a -> Auth @@ -117,7 +118,8 @@ $nothing getLoginR :: YesodAuth m => GHandler Auth m RepHtml getLoginR = defaultLayout $ do setTitle $ string "Login" - mapM_ apLogin authPlugins + tm <- liftHandler getRouteToMaster + mapM_ (flip apLogin tm) authPlugins getLogoutR :: YesodAuth m => GHandler Auth m () getLogoutR = postLogoutR -- FIXME redirect to post @@ -189,11 +191,9 @@ authDummy = setCreds True $ Creds "dummy" ident [] dispatch _ _ = notFound url = PluginR "dummy" [] - authToMaster = liftHandler getRouteToMaster - login = do - tm <- authToMaster + login authToMaster = do addBody [$hamlet| -%form!method=post!action=@tm.url@ +%form!method=post!action=@authToMaster.url@ Your new identifier is: $ %input!type=text!name=ident %input!type=submit!value="Dummy Login" diff --git a/Yesod/Helpers/Auth2/Email.hs b/Yesod/Helpers/Auth2/Email.hs index 330b964f..9d931c83 100644 --- a/Yesod/Helpers/Auth2/Email.hs +++ b/Yesod/Helpers/Auth2/Email.hs @@ -76,8 +76,7 @@ authEmail = dispatch "POST" ["set-password"] = go postPasswordR dispatch _ _ = notFound - login' = do - tm <- liftHandler getRouteToMaster + login' tm = do addBody [$hamlet| %form!method=post!action=@tm.login@ %table diff --git a/Yesod/Helpers/Auth2/Facebook.hs b/Yesod/Helpers/Auth2/Facebook.hs index dd0af3a9..84ea6df2 100644 --- a/Yesod/Helpers/Auth2/Facebook.hs +++ b/Yesod/Helpers/Auth2/Facebook.hs @@ -40,8 +40,7 @@ authFacebook cid secret perms = ] setCreds True c dispatch _ _ = notFound - login = do - tm <- liftHandler getRouteToMaster + login tm = do render <- liftHandler getUrlRender let fb = Facebook.Facebook cid secret $ render $ tm url let furl = Facebook.getForwardUrl fb $ perms diff --git a/Yesod/Helpers/Auth2/OpenId.hs b/Yesod/Helpers/Auth2/OpenId.hs index 914a2dc0..d512bc5a 100644 --- a/Yesod/Helpers/Auth2/OpenId.hs +++ b/Yesod/Helpers/Auth2/OpenId.hs @@ -17,8 +17,7 @@ authOpenId = complete1 = PluginR "openid" ["complete1"] complete2 = PluginR "openid" ["complete2"] name = "openid_identifier" - login = do - tm <- liftHandler getRouteToMaster + login tm = do addStyle [$cassius| #openid background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%; diff --git a/Yesod/Helpers/Auth2/Rpxnow.hs b/Yesod/Helpers/Auth2/Rpxnow.hs index faa127e9..c7e341b7 100644 --- a/Yesod/Helpers/Auth2/Rpxnow.hs +++ b/Yesod/Helpers/Auth2/Rpxnow.hs @@ -15,8 +15,7 @@ authRpxnow :: YesodAuth m authRpxnow app apiKey = AuthPlugin "rpxnow" dispatch login where - login = do - tm <- liftHandler getRouteToMaster + login tm = do let url = {- FIXME urlEncode $ -} tm $ PluginR "rpxnow" [] addBody [$hamlet| %iframe!src="http://$app$.rpxnow.com/openid/embed?token_url=@url@"!scrolling=no!frameBorder=no!allowtransparency=true!style="width:400px;height:240px" diff --git a/yesod-auth.cabal b/yesod-auth.cabal index 8656ac0f..cc71323b 100644 --- a/yesod-auth.cabal +++ b/yesod-auth.cabal @@ -1,5 +1,5 @@ name: yesod-auth -version: 0.0.1 +version: 0.1.0 license: BSD3 license-file: LICENSE author: Michael Snoyman From 9ba28dc72ec0d4f0c426e1d482b29f22fa63da13 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 4 Oct 2010 17:07:55 +0200 Subject: [PATCH 06/69] Use newIdent for identifiers --- Yesod/Helpers/Auth2/Email.hs | 2 +- Yesod/Helpers/Auth2/OpenId.hs | 5 +++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/Yesod/Helpers/Auth2/Email.hs b/Yesod/Helpers/Auth2/Email.hs index 9d931c83..d1574bd5 100644 --- a/Yesod/Helpers/Auth2/Email.hs +++ b/Yesod/Helpers/Auth2/Email.hs @@ -103,7 +103,7 @@ getRegisterR = do %p Enter your e-mail address below, and a confirmation e-mail will be sent to you. %form!method=post!action=@toMaster.register@ %label!for=email E-mail - %input#email!type=email!name=email!width=150 + %input!type=email!name=email!width=150 %input!type=submit!value=Register |] diff --git a/Yesod/Helpers/Auth2/OpenId.hs b/Yesod/Helpers/Auth2/OpenId.hs index d512bc5a..13f57aab 100644 --- a/Yesod/Helpers/Auth2/OpenId.hs +++ b/Yesod/Helpers/Auth2/OpenId.hs @@ -18,15 +18,16 @@ authOpenId = complete2 = PluginR "openid" ["complete2"] name = "openid_identifier" login tm = do + ident <- newIdent addStyle [$cassius| -#openid +#$ident$ background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%; padding-left: 18px; |] addBody [$hamlet| %form!method=post!action=@tm.forward@ %label!for=openid OpenID: $ - %input#openid!type=text!name=$name$ + %input#$ident$!type=text!name=$name$ %input!type=submit!value="Login via OpenID" |] forward2 complete' oid = do From 3342dd5db91791738c78cc17887d6daf95e19c50 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 5 Oct 2010 09:26:05 +0200 Subject: [PATCH 07/69] defaultDest -> loginDest, logoutDest --- Yesod/Helpers/Auth2.hs | 12 ++++++++---- Yesod/Helpers/Auth2/Email.hs | 2 +- auth2.hs | 3 ++- 3 files changed, 11 insertions(+), 6 deletions(-) diff --git a/Yesod/Helpers/Auth2.hs b/Yesod/Helpers/Auth2.hs index a3a6cfe6..616cb434 100644 --- a/Yesod/Helpers/Auth2.hs +++ b/Yesod/Helpers/Auth2.hs @@ -47,9 +47,13 @@ data Creds m = Creds class Yesod m => YesodAuth m where type AuthId m - -- | Default destination on successful login or logout, if no other + -- | Default destination on successful login, if no other -- destination exists. - defaultDest :: m -> Route m + loginDest :: m -> Route m + + -- | Default destination on successful logout, if no other + -- destination exists. + logoutDest :: m -> Route m getAuthId :: Creds m -> GHandler s m (Maybe (AuthId m)) @@ -93,7 +97,7 @@ setCreds doRedirects creds = do if doRedirects then do setMessage $ string "You are now logged in" - redirect RedirectTemporary $ defaultDest y + redirect RedirectTemporary $ loginDest y else return () getCheckR :: YesodAuth m => GHandler Auth m RepHtmlJson @@ -128,7 +132,7 @@ postLogoutR :: YesodAuth m => GHandler Auth m () postLogoutR = do y <- getYesod deleteSession credsKey - redirectUltDest RedirectTemporary $ defaultDest y + redirectUltDest RedirectTemporary $ logoutDest y handlePluginR :: YesodAuth m => String -> [String] -> GHandler Auth m () handlePluginR plugin pieces = do diff --git a/Yesod/Helpers/Auth2/Email.hs b/Yesod/Helpers/Auth2/Email.hs index d1574bd5..3c4e5e82 100644 --- a/Yesod/Helpers/Auth2/Email.hs +++ b/Yesod/Helpers/Auth2/Email.hs @@ -228,7 +228,7 @@ postPasswordR = do setPassword aid salted setMessage $ string "Password updated" y <- getYesod - redirect RedirectTemporary $ defaultDest y + redirect RedirectTemporary $ loginDest y saltLength :: Int saltLength = 5 diff --git a/auth2.hs b/auth2.hs index 54b2e99c..cc6067c3 100644 --- a/auth2.hs +++ b/auth2.hs @@ -29,7 +29,8 @@ mkYesod "A2" [$parseRoutes| instance Yesod A2 where approot _ = "http://localhost:3000" instance YesodAuth A2 where type AuthId A2 = String - defaultDest _ = AuthR CheckR + loginDest _ = AuthR CheckR + logoutDest _ = AuthR CheckR getAuthId = return . Just . credsIdent showAuthId = const id readAuthId = const Just From ba671beb8dddd224618cefddd6fc9eaa59072803 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 5 Oct 2010 09:26:12 +0200 Subject: [PATCH 08/69] authenticate 0.6.6 --- Yesod/Helpers/Auth2/OpenId.hs | 76 ++++++++++++----------------------- yesod-auth.cabal | 3 +- 2 files changed, 27 insertions(+), 52 deletions(-) diff --git a/Yesod/Helpers/Auth2/OpenId.hs b/Yesod/Helpers/Auth2/OpenId.hs index 13f57aab..1a2e0a4d 100644 --- a/Yesod/Helpers/Auth2/OpenId.hs +++ b/Yesod/Helpers/Auth2/OpenId.hs @@ -1,19 +1,23 @@ {-# LANGUAGE QuasiQuotes #-} module Yesod.Helpers.Auth2.OpenId ( authOpenId + , forwardUrl ) where import Yesod import Yesod.Helpers.Auth2 import qualified Web.Authenticate.OpenId as OpenId import Control.Monad.Attempt -import Network.OpenID +import qualified Web.Authenticate.OpenId2 as OpenId2 +import Control.Exception (toException) + +forwardUrl :: AuthRoute +forwardUrl = PluginR "openid" ["forward"] authOpenId :: YesodAuth m => AuthPlugin m authOpenId = AuthPlugin "openid" dispatch login where - forward = PluginR "openid" ["forward"] complete1 = PluginR "openid" ["complete1"] complete2 = PluginR "openid" ["complete2"] name = "openid_identifier" @@ -25,42 +29,30 @@ authOpenId = padding-left: 18px; |] addBody [$hamlet| -%form!method=post!action=@tm.forward@ +%form!method=get!action=@tm.forwardUrl@ %label!for=openid OpenID: $ %input#$ident$!type=text!name=$name$ %input!type=submit!value="Login via OpenID" |] - forward2 complete' oid = do - case normalizeIdentifier $ Identifier oid of - Nothing -> return $ "Unable to normalize identifier: " ++ oid - Just ident -> do - let resolve = liftIO . makeRequest True - rpi <- liftIO $ discover resolve ident - case rpi of - Left err -> return $ "Error on discovery: " ++ show err - Right (p, i) -> do - eam <- liftIO $ associate emptyAssociationMap True resolve p - case eam of - Left err -> return $ "Error on associate: " ++ show err - Right am -> do - let au = authenticationURI am Setup p i complete' Nothing - setSession "OPENID_AM" $ show am - redirectString RedirectTemporary $ show au - dispatch "POST" ["forward"] = do - (roid, _, _) <- runFormPost $ stringInput name + dispatch "GET" ["forward"] = do + (roid, _, _) <- runFormGet $ stringInput name case roid of FormSuccess oid -> do render <- getUrlRender toMaster <- getRouteToMaster let complete2' = render $ toMaster complete2 - msg <- forward2 complete2' oid + res2 <- runAttemptT $ OpenId2.getForwardUrl oid complete2' + msg <- + case res2 of + Failure e -> return $ toException e + Success url -> redirectString RedirectTemporary url let complete' = render $ toMaster complete1 res <- runAttemptT $ OpenId.getForwardUrl oid complete' attempt (\err -> do setMessage $ string $ unlines [ show err - , msg + , show $ toException msg ] redirect RedirectTemporary $ toMaster LoginR ) @@ -70,10 +62,19 @@ authOpenId = toMaster <- getRouteToMaster setMessage $ string "No OpenID identifier found" redirect RedirectTemporary $ toMaster LoginR - dispatch "GET" ["complete1"] = do + dispatch "GET" ["complete1"] = completeHelper OpenId.authenticate + dispatch "GET" ["complete2"] = + completeHelper (fmap OpenId.Identifier . OpenId2.authenticate) + dispatch _ _ = notFound + +completeHelper + :: YesodAuth m + => ([(String, String)] -> AttemptT (GHandler Auth m) OpenId.Identifier) + -> GHandler Auth m () +completeHelper auth = do rr <- getRequest let gets' = reqGetParams rr - res <- runAttemptT $ OpenId.authenticate gets' + res <- runAttemptT $ auth gets' toMaster <- getRouteToMaster let onFailure err = do setMessage $ string $ show err @@ -81,28 +82,3 @@ authOpenId = let onSuccess (OpenId.Identifier ident) = setCreds True $ Creds "openid" ident [] attempt onFailure onSuccess res - dispatch "GET" ["complete2"] = do - amString <- lookupSession "OPENID_AM" - deleteSession "OPENID_AM" - params <- reqGetParams `fmap` getRequest - let am = case amString >>= readMay of - Nothing -> emptyAssociationMap - Just x -> x - let resolve = liftIO . makeRequest True - render <- getUrlRender - toMaster <- getRouteToMaster - let complete2' = render $ toMaster complete2 - res <- liftIO $ verifyAuthentication am params complete2' resolve - let mident = lookup "openid.identity" params - case (res, mident) of - (Right (), Just ident) -> - setCreds True $ Creds "openid" ident [] - _ -> do - setMessage $ string "Error logging in via OpenID" - redirect RedirectTemporary $ toMaster LoginR - dispatch _ _ = notFound - -readMay :: Read a => String -> Maybe a -readMay s = case reads s of - (x, _):_ -> Just x - [] -> Nothing diff --git a/yesod-auth.cabal b/yesod-auth.cabal index cc71323b..0634eda5 100644 --- a/yesod-auth.cabal +++ b/yesod-auth.cabal @@ -13,7 +13,7 @@ homepage: http://docs.yesodweb.com/ library build-depends: base >= 4 && < 5 - , authenticate >= 0.6.5 && < 0.7 + , authenticate >= 0.6.6 && < 0.7 , bytestring >= 0.9.1.4 && < 0.10 , yesod >= 0.5.1 && < 0.6 , wai >= 0.2 && < 0.3 @@ -23,7 +23,6 @@ library , data-object >= 0.3.1.3 && < 0.4 , control-monad-attempt >= 0.3.0 && < 0.4 , utf8-string >= 0.3.4 && < 0.4 - , openid >= 0.1.7 && < 0.2 exposed-modules: Yesod.Helpers.Auth2 Yesod.Helpers.Auth2.Email Yesod.Helpers.Auth2.Facebook From c9d0fd57a2362c864a75225cd948ed5f4f21161b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 5 Oct 2010 11:17:28 +0200 Subject: [PATCH 09/69] Unified OpenID 1 and 2 --- Yesod/Helpers/Auth2/OpenId.hs | 24 +++++------------------- 1 file changed, 5 insertions(+), 19 deletions(-) diff --git a/Yesod/Helpers/Auth2/OpenId.hs b/Yesod/Helpers/Auth2/OpenId.hs index 1a2e0a4d..1af3196d 100644 --- a/Yesod/Helpers/Auth2/OpenId.hs +++ b/Yesod/Helpers/Auth2/OpenId.hs @@ -8,8 +8,6 @@ import Yesod import Yesod.Helpers.Auth2 import qualified Web.Authenticate.OpenId as OpenId import Control.Monad.Attempt -import qualified Web.Authenticate.OpenId2 as OpenId2 -import Control.Exception (toException) forwardUrl :: AuthRoute forwardUrl = PluginR "openid" ["forward"] @@ -18,8 +16,7 @@ authOpenId :: YesodAuth m => AuthPlugin m authOpenId = AuthPlugin "openid" dispatch login where - complete1 = PluginR "openid" ["complete1"] - complete2 = PluginR "openid" ["complete2"] + complete = PluginR "openid" ["complete"] name = "openid_identifier" login tm = do ident <- newIdent @@ -31,7 +28,7 @@ authOpenId = addBody [$hamlet| %form!method=get!action=@tm.forwardUrl@ %label!for=openid OpenID: $ - %input#$ident$!type=text!name=$name$ + %input#$ident$!type=text!name=$name$!value="http://" %input!type=submit!value="Login via OpenID" |] dispatch "GET" ["forward"] = do @@ -40,20 +37,11 @@ authOpenId = FormSuccess oid -> do render <- getUrlRender toMaster <- getRouteToMaster - let complete2' = render $ toMaster complete2 - res2 <- runAttemptT $ OpenId2.getForwardUrl oid complete2' - msg <- - case res2 of - Failure e -> return $ toException e - Success url -> redirectString RedirectTemporary url - let complete' = render $ toMaster complete1 + let complete' = render $ toMaster complete res <- runAttemptT $ OpenId.getForwardUrl oid complete' attempt (\err -> do - setMessage $ string $ unlines - [ show err - , show $ toException msg - ] + setMessage $ string $ show err redirect RedirectTemporary $ toMaster LoginR ) (redirectString RedirectTemporary) @@ -62,9 +50,7 @@ authOpenId = toMaster <- getRouteToMaster setMessage $ string "No OpenID identifier found" redirect RedirectTemporary $ toMaster LoginR - dispatch "GET" ["complete1"] = completeHelper OpenId.authenticate - dispatch "GET" ["complete2"] = - completeHelper (fmap OpenId.Identifier . OpenId2.authenticate) + dispatch "GET" ["complete"] = completeHelper OpenId.authenticate dispatch _ _ = notFound completeHelper From 961870e1e9ddee44bcb8cb81667236cc8c365f4a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 5 Oct 2010 22:25:25 +0200 Subject: [PATCH 10/69] Added Setup.lhs --- Setup.lhs | 8 ++++++++ 1 file changed, 8 insertions(+) create mode 100755 Setup.lhs diff --git a/Setup.lhs b/Setup.lhs new file mode 100755 index 00000000..1bc517f6 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,8 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple +> import System.Cmd (system) + +> main :: IO () +> main = defaultMain From 0651e8cc8e80184952ab8ff81b88f3f709336b26 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 6 Oct 2010 15:33:36 +0200 Subject: [PATCH 11/69] facebookUrl --- Yesod/Helpers/Auth2/Facebook.hs | 9 +++++++++ yesod-auth.cabal | 2 +- 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/Yesod/Helpers/Auth2/Facebook.hs b/Yesod/Helpers/Auth2/Facebook.hs index 84ea6df2..3acbb4bb 100644 --- a/Yesod/Helpers/Auth2/Facebook.hs +++ b/Yesod/Helpers/Auth2/Facebook.hs @@ -1,6 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} module Yesod.Helpers.Auth2.Facebook ( authFacebook + , facebookUrl ) where import Yesod @@ -9,6 +10,9 @@ import qualified Web.Authenticate.Facebook as Facebook import Data.Object (fromMapping, lookupScalar) import Data.Maybe (fromMaybe) +facebookUrl :: AuthRoute +facebookUrl = PluginR "facebook" ["forward"] + authFacebook :: YesodAuth m => String -- ^ Application ID -> String -- ^ Application secret @@ -18,6 +22,11 @@ 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 + redirectString RedirectTemporary $ Facebook.getForwardUrl fb perms dispatch "GET" [] = do render <- getUrlRender tm <- getRouteToMaster diff --git a/yesod-auth.cabal b/yesod-auth.cabal index 0634eda5..ec662b0d 100644 --- a/yesod-auth.cabal +++ b/yesod-auth.cabal @@ -1,5 +1,5 @@ name: yesod-auth -version: 0.1.0 +version: 0.1.1 license: BSD3 license-file: LICENSE author: Michael Snoyman From 7e19ee078912222d56c70d058483e9a76252fbe7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 10 Oct 2010 10:31:18 +0200 Subject: [PATCH 12/69] authenticate 0.7 --- yesod-auth.cabal | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/yesod-auth.cabal b/yesod-auth.cabal index ec662b0d..0bb7a11f 100644 --- a/yesod-auth.cabal +++ b/yesod-auth.cabal @@ -1,5 +1,5 @@ name: yesod-auth -version: 0.1.1 +version: 0.1.2 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -13,9 +13,9 @@ homepage: http://docs.yesodweb.com/ library build-depends: base >= 4 && < 5 - , authenticate >= 0.6.6 && < 0.7 + , authenticate >= 0.7 && < 0.8 , bytestring >= 0.9.1.4 && < 0.10 - , yesod >= 0.5.1 && < 0.6 + , yesod >= 0.5.2 && < 0.6 , wai >= 0.2 && < 0.3 , template-haskell , pureMD5 >= 1.1 && < 1.2 From 18e901fa524e5316c5ac12de3e2d093633dba875 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 10 Oct 2010 10:32:08 +0200 Subject: [PATCH 13/69] Warnings --- Yesod/Helpers/Auth2/Email.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/Yesod/Helpers/Auth2/Email.hs b/Yesod/Helpers/Auth2/Email.hs index 3c4e5e82..517b6e68 100644 --- a/Yesod/Helpers/Auth2/Email.hs +++ b/Yesod/Helpers/Auth2/Email.hs @@ -12,7 +12,6 @@ import System.Random import Control.Monad (when) import Control.Applicative ((<$>), (<*>)) import Data.Digest.Pure.MD5 -import Data.String (fromString) import qualified Data.ByteString.Lazy.UTF8 as LU login, register, setpass :: AuthRoute @@ -143,7 +142,7 @@ getVerifyR lid key = do muid <- verifyAccount lid case muid of Nothing -> return () - Just uid -> do + Just _uid -> do setCreds False $ Creds "email" email [("verifiedEmail", email)] -- FIXME uid? toMaster <- getRouteToMaster setMessage $ string "Address verified, please set a new password" @@ -160,7 +159,6 @@ postLoginR = do (email, pass) <- runFormPost' $ (,) <$> emailInput "email" <*> stringInput "password" - y <- getYesod mecreds <- getEmailCreds email maid <- case (mecreds >>= emailCredsAuthId, fmap emailCredsStatus mecreds) of @@ -174,7 +172,7 @@ postLoginR = do else Nothing _ -> return Nothing case maid of - Just aid -> + Just _aid -> setCreds True $ Creds "email" email [("verifiedEmail", email)] -- FIXME aid? Nothing -> do setMessage $ string "Invalid email/password combination" From f0cd04fa975479c6ae9d3f3b99b3c99b1b5e3044 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 11 Oct 2010 19:46:48 +0200 Subject: [PATCH 14/69] loginHandler --- Yesod/Helpers/Auth2.hs | 12 ++++++++---- yesod-auth.cabal | 2 +- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/Yesod/Helpers/Auth2.hs b/Yesod/Helpers/Auth2.hs index 616cb434..64614ef3 100644 --- a/Yesod/Helpers/Auth2.hs +++ b/Yesod/Helpers/Auth2.hs @@ -62,6 +62,13 @@ class Yesod m => YesodAuth m where authPlugins :: [AuthPlugin m] + -- | What to show on the login page. + loginHandler :: GHandler Auth m RepHtml + loginHandler = defaultLayout $ do + setTitle $ string "Login" + tm <- liftHandler getRouteToMaster + mapM_ (flip apLogin tm) authPlugins + mkYesodSub "Auth" [ ClassP ''YesodAuth [VarT $ mkName "master"] ] [$parseRoutes| @@ -120,10 +127,7 @@ $nothing ] getLoginR :: YesodAuth m => GHandler Auth m RepHtml -getLoginR = defaultLayout $ do - setTitle $ string "Login" - tm <- liftHandler getRouteToMaster - mapM_ (flip apLogin tm) authPlugins +getLoginR = loginHandler getLogoutR :: YesodAuth m => GHandler Auth m () getLogoutR = postLogoutR -- FIXME redirect to post diff --git a/yesod-auth.cabal b/yesod-auth.cabal index 0bb7a11f..75c151a9 100644 --- a/yesod-auth.cabal +++ b/yesod-auth.cabal @@ -1,5 +1,5 @@ name: yesod-auth -version: 0.1.2 +version: 0.1.3 license: BSD3 license-file: LICENSE author: Michael Snoyman From 8dc5dc66f9b4bc8604d3c6c1ec981a69596438a2 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 13 Oct 2010 22:45:22 +0200 Subject: [PATCH 15/69] openid complete supports POST --- Yesod/Helpers/Auth2/OpenId.hs | 19 ++++++++++--------- yesod-auth.cabal | 2 +- 2 files changed, 11 insertions(+), 10 deletions(-) diff --git a/Yesod/Helpers/Auth2/OpenId.hs b/Yesod/Helpers/Auth2/OpenId.hs index 1af3196d..7f077ceb 100644 --- a/Yesod/Helpers/Auth2/OpenId.hs +++ b/Yesod/Helpers/Auth2/OpenId.hs @@ -50,17 +50,18 @@ authOpenId = toMaster <- getRouteToMaster setMessage $ string "No OpenID identifier found" redirect RedirectTemporary $ toMaster LoginR - dispatch "GET" ["complete"] = completeHelper OpenId.authenticate + dispatch "GET" ["complete"] = do + rr <- getRequest + completeHelper $ reqGetParams rr + dispatch "POST" ["complete"] = do + rr <- getRequest + (posts, _) <- liftIO $ reqRequestBody rr + completeHelper posts dispatch _ _ = notFound -completeHelper - :: YesodAuth m - => ([(String, String)] -> AttemptT (GHandler Auth m) OpenId.Identifier) - -> GHandler Auth m () -completeHelper auth = do - rr <- getRequest - let gets' = reqGetParams rr - res <- runAttemptT $ auth gets' +completeHelper :: YesodAuth m => [(String, String)] -> GHandler Auth m () +completeHelper gets' = do + res <- runAttemptT $ OpenId.authenticate gets' toMaster <- getRouteToMaster let onFailure err = do setMessage $ string $ show err diff --git a/yesod-auth.cabal b/yesod-auth.cabal index 75c151a9..75be7e99 100644 --- a/yesod-auth.cabal +++ b/yesod-auth.cabal @@ -1,5 +1,5 @@ name: yesod-auth -version: 0.1.3 +version: 0.1.4 license: BSD3 license-file: LICENSE author: Michael Snoyman From 203982e3ea069c88bd818607f158be4bf34c77aa Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 15 Oct 2010 12:22:12 +0200 Subject: [PATCH 16/69] Version 0.2, based on yesod 0.6 --- Yesod/Helpers/{Auth2.hs => Auth.hs} | 2 +- Yesod/Helpers/{Auth2 => Auth}/Email.hs | 4 ++-- Yesod/Helpers/{Auth2 => Auth}/Facebook.hs | 4 ++-- Yesod/Helpers/{Auth2 => Auth}/OpenId.hs | 4 ++-- Yesod/Helpers/{Auth2 => Auth}/Rpxnow.hs | 4 ++-- yesod-auth.cabal | 16 ++++++++-------- 6 files changed, 17 insertions(+), 17 deletions(-) rename Yesod/Helpers/{Auth2.hs => Auth.hs} (99%) rename Yesod/Helpers/{Auth2 => Auth}/Email.hs (99%) rename Yesod/Helpers/{Auth2 => Auth}/Facebook.hs (97%) rename Yesod/Helpers/{Auth2 => Auth}/OpenId.hs (97%) rename Yesod/Helpers/{Auth2 => Auth}/Rpxnow.hs (96%) diff --git a/Yesod/Helpers/Auth2.hs b/Yesod/Helpers/Auth.hs similarity index 99% rename from Yesod/Helpers/Auth2.hs rename to Yesod/Helpers/Auth.hs index 64614ef3..898e6f4b 100644 --- a/Yesod/Helpers/Auth2.hs +++ b/Yesod/Helpers/Auth.hs @@ -3,7 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} -module Yesod.Helpers.Auth2 +module Yesod.Helpers.Auth ( Auth , AuthPlugin (..) , AuthRoute (..) diff --git a/Yesod/Helpers/Auth2/Email.hs b/Yesod/Helpers/Auth/Email.hs similarity index 99% rename from Yesod/Helpers/Auth2/Email.hs rename to Yesod/Helpers/Auth/Email.hs index 517b6e68..604ed09b 100644 --- a/Yesod/Helpers/Auth2/Email.hs +++ b/Yesod/Helpers/Auth/Email.hs @@ -1,5 +1,5 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies #-} -module Yesod.Helpers.Auth2.Email +module Yesod.Helpers.Auth.Email ( authEmail , YesodAuthEmail (..) , EmailCreds (..) @@ -7,7 +7,7 @@ module Yesod.Helpers.Auth2.Email import Yesod import Yesod.Mail (randomString) -import Yesod.Helpers.Auth2 +import Yesod.Helpers.Auth import System.Random import Control.Monad (when) import Control.Applicative ((<$>), (<*>)) diff --git a/Yesod/Helpers/Auth2/Facebook.hs b/Yesod/Helpers/Auth/Facebook.hs similarity index 97% rename from Yesod/Helpers/Auth2/Facebook.hs rename to Yesod/Helpers/Auth/Facebook.hs index 3acbb4bb..0c9d237e 100644 --- a/Yesod/Helpers/Auth2/Facebook.hs +++ b/Yesod/Helpers/Auth/Facebook.hs @@ -1,11 +1,11 @@ {-# LANGUAGE QuasiQuotes #-} -module Yesod.Helpers.Auth2.Facebook +module Yesod.Helpers.Auth.Facebook ( authFacebook , facebookUrl ) where import Yesod -import Yesod.Helpers.Auth2 +import Yesod.Helpers.Auth import qualified Web.Authenticate.Facebook as Facebook import Data.Object (fromMapping, lookupScalar) import Data.Maybe (fromMaybe) diff --git a/Yesod/Helpers/Auth2/OpenId.hs b/Yesod/Helpers/Auth/OpenId.hs similarity index 97% rename from Yesod/Helpers/Auth2/OpenId.hs rename to Yesod/Helpers/Auth/OpenId.hs index 7f077ceb..341d6c1d 100644 --- a/Yesod/Helpers/Auth2/OpenId.hs +++ b/Yesod/Helpers/Auth/OpenId.hs @@ -1,11 +1,11 @@ {-# LANGUAGE QuasiQuotes #-} -module Yesod.Helpers.Auth2.OpenId +module Yesod.Helpers.Auth.OpenId ( authOpenId , forwardUrl ) where import Yesod -import Yesod.Helpers.Auth2 +import Yesod.Helpers.Auth import qualified Web.Authenticate.OpenId as OpenId import Control.Monad.Attempt diff --git a/Yesod/Helpers/Auth2/Rpxnow.hs b/Yesod/Helpers/Auth/Rpxnow.hs similarity index 96% rename from Yesod/Helpers/Auth2/Rpxnow.hs rename to Yesod/Helpers/Auth/Rpxnow.hs index c7e341b7..321f1caa 100644 --- a/Yesod/Helpers/Auth2/Rpxnow.hs +++ b/Yesod/Helpers/Auth/Rpxnow.hs @@ -1,10 +1,10 @@ {-# LANGUAGE QuasiQuotes #-} -module Yesod.Helpers.Auth2.Rpxnow +module Yesod.Helpers.Auth.Rpxnow ( authRpxnow ) where import Yesod -import Yesod.Helpers.Auth2 +import Yesod.Helpers.Auth import qualified Web.Authenticate.Rpxnow as Rpxnow import Control.Monad (mplus) diff --git a/yesod-auth.cabal b/yesod-auth.cabal index 75be7e99..33951115 100644 --- a/yesod-auth.cabal +++ b/yesod-auth.cabal @@ -1,5 +1,5 @@ name: yesod-auth -version: 0.1.4 +version: 0.2.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -15,7 +15,7 @@ library build-depends: base >= 4 && < 5 , authenticate >= 0.7 && < 0.8 , bytestring >= 0.9.1.4 && < 0.10 - , yesod >= 0.5.2 && < 0.6 + , yesod >= 0.6 && < 0.7 , wai >= 0.2 && < 0.3 , template-haskell , pureMD5 >= 1.1 && < 1.2 @@ -23,13 +23,13 @@ library , data-object >= 0.3.1.3 && < 0.4 , control-monad-attempt >= 0.3.0 && < 0.4 , utf8-string >= 0.3.4 && < 0.4 - exposed-modules: Yesod.Helpers.Auth2 - Yesod.Helpers.Auth2.Email - Yesod.Helpers.Auth2.Facebook - Yesod.Helpers.Auth2.OpenId - Yesod.Helpers.Auth2.Rpxnow + exposed-modules: Yesod.Helpers.Auth + Yesod.Helpers.Auth.Email + Yesod.Helpers.Auth.Facebook + Yesod.Helpers.Auth.OpenId + Yesod.Helpers.Auth.Rpxnow ghc-options: -Wall source-repository head type: git - location: git://github.com/snoyberg/yesod.git + location: git://github.com/snoyberg/yesod-auth.git From fb5973bac8f6c58dab3eaffa07f0892e46803847 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 15 Oct 2010 12:41:01 +0200 Subject: [PATCH 17/69] Including Yesod.Mail --- Yesod/Mail.hs | 125 +++++++++++++++++++++++++++++++++++++++++++++++ yesod-auth.cabal | 4 ++ 2 files changed, 129 insertions(+) create mode 100644 Yesod/Mail.hs diff --git a/Yesod/Mail.hs b/Yesod/Mail.hs new file mode 100644 index 00000000..7c9f1896 --- /dev/null +++ b/Yesod/Mail.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Support for sending email. +-- +-- This could be released completely separately from yesod/yesod-auth. If this +-- would be useful for anyone, please let me know. +module Yesod.Mail + ( Boundary (..) + , Mail (..) + , Part (..) + , Encoding (..) + , renderMail + , renderMail' + , sendmail + , Disposition (..) + , renderSendMail + , randomString + ) where + +import qualified Data.ByteString.Lazy as L +import Text.Blaze.Builder.Utf8 +import Text.Blaze.Builder.Core +import Data.Monoid +import System.Random +import Control.Arrow +import System.Process +import System.IO +import System.Exit +import Codec.Binary.Base64 (encode) +import Control.Monad ((<=<)) + +randomString :: RandomGen d => Int -> d -> (String, d) +randomString len = + first (map toChar) . sequence' (replicate len (randomR (0, 61))) + where + sequence' [] g = ([], g) + sequence' (f:fs) g = + let (f', g') = f g + (fs', g'') = sequence' fs g' + in (f' : fs', g'') + toChar i + | i < 26 = toEnum $ i + fromEnum 'A' + | i < 52 = toEnum $ i + fromEnum 'a' - 26 + | otherwise = toEnum $ i + fromEnum '0' - 52 + +newtype Boundary = Boundary { unBoundary :: String } +instance Random Boundary where + randomR = const random + random = first Boundary . randomString 10 + +data Mail = Mail + { mailHeaders :: [(String, String)] + , mailPlain :: String + , mailParts :: [Part] + } + +data Encoding = None | Base64 + +data Part = Part + { partType :: String -- ^ content type + , partEncoding :: Encoding + , partDisposition :: Disposition + , partContent :: L.ByteString + } + +data Disposition = Inline | Attachment String + +renderMail :: Boundary -> Mail -> L.ByteString +renderMail (Boundary b) (Mail headers plain parts) = toLazyByteString $ mconcat + [ mconcat $ map showHeader headers + , mconcat $ map showHeader + [ ("MIME-Version", "1.0") + , ("Content-Type", "multipart/mixed; boundary=\"" + ++ b ++ "\"") + ] + , fromByteString "\n" + , fromString plain + , mconcat $ map showPart parts + , fromByteString "\n--" + , fromString b + , fromByteString "--" + ] + where + showHeader (k, v) = mconcat + [ fromString k + , fromByteString ": " + , fromString v + , fromByteString "\n" + ] + showPart (Part contentType encoding disposition content) = mconcat + [ fromByteString "\n--" + , fromString b + , fromByteString "\n" + , showHeader ("Content-Type", contentType) + , case encoding of + None -> mempty + Base64 -> showHeader ("Content-Transfer-Encoding", "base64") + , case disposition of + Inline -> mempty + Attachment filename -> + showHeader ("Content-Disposition", "attachment; filename=" ++ filename) + , fromByteString "\n" + , case encoding of + None -> writeList writeByteString $ L.toChunks content + Base64 -> writeList writeByte $ map (toEnum . fromEnum) + $ encode $ L.unpack content + ] + +renderMail' :: Mail -> IO L.ByteString +renderMail' m = do + b <- randomIO + return $ renderMail b m + +sendmail :: L.ByteString -> IO () +sendmail lbs = do + (Just hin, _, _, phandle) <- createProcess $ (proc + "/usr/sbin/sendmail" ["-t"]) { std_in = CreatePipe } + L.hPut hin lbs + hClose hin + exitCode <- waitForProcess phandle + case exitCode of + ExitSuccess -> return () + _ -> error $ "sendmail exited with error code " ++ show exitCode + +renderSendMail :: Mail -> IO () +renderSendMail = sendmail <=< renderMail' diff --git a/yesod-auth.cabal b/yesod-auth.cabal index 33951115..3f86a952 100644 --- a/yesod-auth.cabal +++ b/yesod-auth.cabal @@ -23,11 +23,15 @@ library , data-object >= 0.3.1.3 && < 0.4 , control-monad-attempt >= 0.3.0 && < 0.4 , utf8-string >= 0.3.4 && < 0.4 + , process >= 1.0 && < 1.1 + , blaze-builder >= 0.1 && < 0.2 + , dataenc >= 0.13 && < 0.14 exposed-modules: Yesod.Helpers.Auth Yesod.Helpers.Auth.Email Yesod.Helpers.Auth.Facebook Yesod.Helpers.Auth.OpenId Yesod.Helpers.Auth.Rpxnow + Yesod.Mail ghc-options: -Wall source-repository head From 0365e46a3eb8fdc67599b8de5e18d30071d8e210 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 18 Oct 2010 17:29:57 +0200 Subject: [PATCH 18/69] mime-mail --- Yesod/Helpers/Auth/Email.hs | 2 +- Yesod/Mail.hs | 125 ------------------------------------ yesod-auth.cabal | 4 +- 3 files changed, 2 insertions(+), 129 deletions(-) delete mode 100644 Yesod/Mail.hs diff --git a/Yesod/Helpers/Auth/Email.hs b/Yesod/Helpers/Auth/Email.hs index 604ed09b..535486f9 100644 --- a/Yesod/Helpers/Auth/Email.hs +++ b/Yesod/Helpers/Auth/Email.hs @@ -6,7 +6,7 @@ module Yesod.Helpers.Auth.Email ) where import Yesod -import Yesod.Mail (randomString) +import Network.Mail.Mime (randomString) import Yesod.Helpers.Auth import System.Random import Control.Monad (when) diff --git a/Yesod/Mail.hs b/Yesod/Mail.hs deleted file mode 100644 index 7c9f1896..00000000 --- a/Yesod/Mail.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- | Support for sending email. --- --- This could be released completely separately from yesod/yesod-auth. If this --- would be useful for anyone, please let me know. -module Yesod.Mail - ( Boundary (..) - , Mail (..) - , Part (..) - , Encoding (..) - , renderMail - , renderMail' - , sendmail - , Disposition (..) - , renderSendMail - , randomString - ) where - -import qualified Data.ByteString.Lazy as L -import Text.Blaze.Builder.Utf8 -import Text.Blaze.Builder.Core -import Data.Monoid -import System.Random -import Control.Arrow -import System.Process -import System.IO -import System.Exit -import Codec.Binary.Base64 (encode) -import Control.Monad ((<=<)) - -randomString :: RandomGen d => Int -> d -> (String, d) -randomString len = - first (map toChar) . sequence' (replicate len (randomR (0, 61))) - where - sequence' [] g = ([], g) - sequence' (f:fs) g = - let (f', g') = f g - (fs', g'') = sequence' fs g' - in (f' : fs', g'') - toChar i - | i < 26 = toEnum $ i + fromEnum 'A' - | i < 52 = toEnum $ i + fromEnum 'a' - 26 - | otherwise = toEnum $ i + fromEnum '0' - 52 - -newtype Boundary = Boundary { unBoundary :: String } -instance Random Boundary where - randomR = const random - random = first Boundary . randomString 10 - -data Mail = Mail - { mailHeaders :: [(String, String)] - , mailPlain :: String - , mailParts :: [Part] - } - -data Encoding = None | Base64 - -data Part = Part - { partType :: String -- ^ content type - , partEncoding :: Encoding - , partDisposition :: Disposition - , partContent :: L.ByteString - } - -data Disposition = Inline | Attachment String - -renderMail :: Boundary -> Mail -> L.ByteString -renderMail (Boundary b) (Mail headers plain parts) = toLazyByteString $ mconcat - [ mconcat $ map showHeader headers - , mconcat $ map showHeader - [ ("MIME-Version", "1.0") - , ("Content-Type", "multipart/mixed; boundary=\"" - ++ b ++ "\"") - ] - , fromByteString "\n" - , fromString plain - , mconcat $ map showPart parts - , fromByteString "\n--" - , fromString b - , fromByteString "--" - ] - where - showHeader (k, v) = mconcat - [ fromString k - , fromByteString ": " - , fromString v - , fromByteString "\n" - ] - showPart (Part contentType encoding disposition content) = mconcat - [ fromByteString "\n--" - , fromString b - , fromByteString "\n" - , showHeader ("Content-Type", contentType) - , case encoding of - None -> mempty - Base64 -> showHeader ("Content-Transfer-Encoding", "base64") - , case disposition of - Inline -> mempty - Attachment filename -> - showHeader ("Content-Disposition", "attachment; filename=" ++ filename) - , fromByteString "\n" - , case encoding of - None -> writeList writeByteString $ L.toChunks content - Base64 -> writeList writeByte $ map (toEnum . fromEnum) - $ encode $ L.unpack content - ] - -renderMail' :: Mail -> IO L.ByteString -renderMail' m = do - b <- randomIO - return $ renderMail b m - -sendmail :: L.ByteString -> IO () -sendmail lbs = do - (Just hin, _, _, phandle) <- createProcess $ (proc - "/usr/sbin/sendmail" ["-t"]) { std_in = CreatePipe } - L.hPut hin lbs - hClose hin - exitCode <- waitForProcess phandle - case exitCode of - ExitSuccess -> return () - _ -> error $ "sendmail exited with error code " ++ show exitCode - -renderSendMail :: Mail -> IO () -renderSendMail = sendmail <=< renderMail' diff --git a/yesod-auth.cabal b/yesod-auth.cabal index 3f86a952..e8836861 100644 --- a/yesod-auth.cabal +++ b/yesod-auth.cabal @@ -23,15 +23,13 @@ library , data-object >= 0.3.1.3 && < 0.4 , control-monad-attempt >= 0.3.0 && < 0.4 , utf8-string >= 0.3.4 && < 0.4 - , process >= 1.0 && < 1.1 , blaze-builder >= 0.1 && < 0.2 - , dataenc >= 0.13 && < 0.14 + , mime-mail >= 0.0 && < 0.1 exposed-modules: Yesod.Helpers.Auth Yesod.Helpers.Auth.Email Yesod.Helpers.Auth.Facebook Yesod.Helpers.Auth.OpenId Yesod.Helpers.Auth.Rpxnow - Yesod.Mail ghc-options: -Wall source-repository head From 23141acaacc259dd9d7abb1d31ce2b2eca5b92c6 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 19 Oct 2010 07:29:27 +0200 Subject: [PATCH 19/69] Exported saltPass --- Yesod/Helpers/Auth/Email.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/Yesod/Helpers/Auth/Email.hs b/Yesod/Helpers/Auth/Email.hs index 535486f9..0b1fadac 100644 --- a/Yesod/Helpers/Auth/Email.hs +++ b/Yesod/Helpers/Auth/Email.hs @@ -3,6 +3,7 @@ module Yesod.Helpers.Auth.Email ( authEmail , YesodAuthEmail (..) , EmailCreds (..) + , saltPass ) where import Yesod @@ -231,6 +232,7 @@ postPasswordR = do saltLength :: Int saltLength = 5 +-- | Salt a password with a randomly generated salt. saltPass :: String -> IO String saltPass pass = do stdgen <- newStdGen From 20b0790c2593f5a30ef33a89eae77091dd3cc78d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 20 Oct 2010 16:56:35 +0200 Subject: [PATCH 20/69] pureMD5 bump --- yesod-auth.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-auth.cabal b/yesod-auth.cabal index e8836861..9e20d17d 100644 --- a/yesod-auth.cabal +++ b/yesod-auth.cabal @@ -18,7 +18,7 @@ library , yesod >= 0.6 && < 0.7 , wai >= 0.2 && < 0.3 , template-haskell - , pureMD5 >= 1.1 && < 1.2 + , pureMD5 >= 1.1 && < 2.2 , random >= 1.0 && < 1.1 , data-object >= 0.3.1.3 && < 0.4 , control-monad-attempt >= 0.3.0 && < 0.4 From 46d8398d7a980d5b2b2568ae02d35fc6ee27f57c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 20 Oct 2010 22:50:48 +0200 Subject: [PATCH 21/69] Moved authDummy to a separate module --- Yesod/Helpers/Auth.hs | 26 ++++++-------------------- Yesod/Helpers/Auth/Dummy.hs | 27 +++++++++++++++++++++++++++ yesod-auth.cabal | 1 + 3 files changed, 34 insertions(+), 20 deletions(-) create mode 100644 Yesod/Helpers/Auth/Dummy.hs diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 898e6f4b..43043fe6 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -4,18 +4,20 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} module Yesod.Helpers.Auth - ( Auth + ( -- * Subsite + Auth , AuthPlugin (..) , AuthRoute (..) , getAuth - , Creds (..) , YesodAuth (..) + -- * Plugin interface + , Creds (..) , setCreds + -- * User functions , maybeAuthId , maybeAuth , requireAuthId , requireAuth - , authDummy ) where import Yesod @@ -81,6 +83,7 @@ mkYesodSub "Auth" credsKey :: String credsKey = "_ID" +-- | FIXME: won't show up till redirect setCreds :: YesodAuth m => Bool -> Creds m -> GHandler s m () setCreds doRedirects creds = do y <- getYesod @@ -189,20 +192,3 @@ redirectLogin = do case authRoute y of Just z -> redirect RedirectTemporary z Nothing -> permissionDenied "Please configure authRoute" - -authDummy :: YesodAuth m => AuthPlugin m -authDummy = - AuthPlugin "dummy" dispatch login - where - dispatch "POST" [] = do - ident <- runFormPost' $ stringInput "ident" - setCreds True $ Creds "dummy" ident [] - dispatch _ _ = notFound - url = PluginR "dummy" [] - login authToMaster = do - addBody [$hamlet| -%form!method=post!action=@authToMaster.url@ - Your new identifier is: $ - %input!type=text!name=ident - %input!type=submit!value="Dummy Login" -|] diff --git a/Yesod/Helpers/Auth/Dummy.hs b/Yesod/Helpers/Auth/Dummy.hs new file mode 100644 index 00000000..1cbde6be --- /dev/null +++ b/Yesod/Helpers/Auth/Dummy.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE QuasiQuotes #-} +-- | Provides a dummy authentication module that simply lets a user specify +-- his/her identifier. This is not intended for real world use, just for +-- testing. +module Yesod.Helpers.Auth.Dummy + ( authDummy + ) where + +import Yesod +import Yesod.Helpers.Auth + +authDummy :: YesodAuth m => AuthPlugin m +authDummy = + AuthPlugin "dummy" dispatch login + where + dispatch "POST" [] = do + ident <- runFormPost' $ stringInput "ident" + setCreds True $ Creds "dummy" ident [] + dispatch _ _ = notFound + url = PluginR "dummy" [] + login authToMaster = do + addBody [$hamlet| +%form!method=post!action=@authToMaster.url@ + Your new identifier is: $ + %input!type=text!name=ident + %input!type=submit!value="Dummy Login" +|] diff --git a/yesod-auth.cabal b/yesod-auth.cabal index 9e20d17d..f47b04b3 100644 --- a/yesod-auth.cabal +++ b/yesod-auth.cabal @@ -26,6 +26,7 @@ library , blaze-builder >= 0.1 && < 0.2 , mime-mail >= 0.0 && < 0.1 exposed-modules: Yesod.Helpers.Auth + Yesod.Helpers.Auth.Dummy Yesod.Helpers.Auth.Email Yesod.Helpers.Auth.Facebook Yesod.Helpers.Auth.OpenId From 881ea26d83336d50e87f0da77ba74b8165494d07 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 24 Oct 2010 22:37:56 +0200 Subject: [PATCH 22/69] yesod changes --- Yesod/Helpers/Auth.hs | 6 ++---- Yesod/Helpers/Auth/Dummy.hs | 3 +-- Yesod/Helpers/Auth/Email.hs | 11 +++++------ Yesod/Helpers/Auth/Facebook.hs | 2 +- Yesod/Helpers/Auth/OpenId.hs | 4 ++-- Yesod/Helpers/Auth/Rpxnow.hs | 2 +- 6 files changed, 12 insertions(+), 16 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 43043fe6..111be0f4 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -94,9 +94,7 @@ setCreds doRedirects creds = do then do case authRoute y of Nothing -> do - rh <- defaultLayout $ addBody [$hamlet| -%h1 Invalid login -|] + rh <- defaultLayout [$hamlet|%h1 Invalid login|] sendResponse rh Just ar -> do setMessage $ string "Invalid login" @@ -115,7 +113,7 @@ getCheckR = do creds <- maybeAuthId defaultLayoutJson (do setTitle $ string "Authentication Status" - addBody $ html creds) (json creds) + addHtml $ html creds) (json creds) where html creds = [$hamlet| %h1 Authentication Status diff --git a/Yesod/Helpers/Auth/Dummy.hs b/Yesod/Helpers/Auth/Dummy.hs index 1cbde6be..03bc7fd9 100644 --- a/Yesod/Helpers/Auth/Dummy.hs +++ b/Yesod/Helpers/Auth/Dummy.hs @@ -18,8 +18,7 @@ authDummy = setCreds True $ Creds "dummy" ident [] dispatch _ _ = notFound url = PluginR "dummy" [] - login authToMaster = do - addBody [$hamlet| + login authToMaster = [$hamlet| %form!method=post!action=@authToMaster.url@ Your new identifier is: $ %input!type=text!name=ident diff --git a/Yesod/Helpers/Auth/Email.hs b/Yesod/Helpers/Auth/Email.hs index 0b1fadac..581d8c9c 100644 --- a/Yesod/Helpers/Auth/Email.hs +++ b/Yesod/Helpers/Auth/Email.hs @@ -76,8 +76,7 @@ authEmail = dispatch "POST" ["set-password"] = go postPasswordR dispatch _ _ = notFound - login' tm = do - addBody [$hamlet| + login' tm = [$hamlet| %form!method=post!action=@tm.login@ %table %tr @@ -99,7 +98,7 @@ getRegisterR = do toMaster <- getRouteToMaster defaultLayout $ do setTitle $ string "Register a new account" - addBody [$hamlet| + addHamlet [$hamlet| %p Enter your e-mail address below, and a confirmation e-mail will be sent to you. %form!method=post!action=@toMaster.register@ %label!for=email E-mail @@ -129,7 +128,7 @@ postRegisterR = do sendVerifyEmail email verKey verUrl defaultLayout $ do setTitle $ string "Confirmation e-mail sent" - addBody [$hamlet| + addWidget [$hamlet| %p A confirmation e-mail has been sent to $email$. |] @@ -151,7 +150,7 @@ getVerifyR lid key = do _ -> return () defaultLayout $ do setTitle $ string "Invalid verification key" - addBody [$hamlet| + addHtml [$hamlet| %p I'm sorry, but that was an invalid verification key. |] @@ -191,7 +190,7 @@ getPasswordR = do redirect RedirectTemporary $ toMaster login defaultLayout $ do setTitle $ string "Set password" - addBody [$hamlet| + addHamlet [$hamlet| %h3 Set a new password %form!method=post!action=@toMaster.setpass@ %table diff --git a/Yesod/Helpers/Auth/Facebook.hs b/Yesod/Helpers/Auth/Facebook.hs index 0c9d237e..0a4b9388 100644 --- a/Yesod/Helpers/Auth/Facebook.hs +++ b/Yesod/Helpers/Auth/Facebook.hs @@ -53,7 +53,7 @@ authFacebook cid secret perms = render <- liftHandler getUrlRender let fb = Facebook.Facebook cid secret $ render $ tm url let furl = Facebook.getForwardUrl fb $ perms - addBody [$hamlet| + addHtml [$hamlet| %p %a!href=$furl$ Login with Facebook |] diff --git a/Yesod/Helpers/Auth/OpenId.hs b/Yesod/Helpers/Auth/OpenId.hs index 341d6c1d..62d0b7bf 100644 --- a/Yesod/Helpers/Auth/OpenId.hs +++ b/Yesod/Helpers/Auth/OpenId.hs @@ -20,12 +20,12 @@ authOpenId = name = "openid_identifier" login tm = do ident <- newIdent - addStyle [$cassius| + addCassius [$cassius| #$ident$ background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%; padding-left: 18px; |] - addBody [$hamlet| + addHamlet [$hamlet| %form!method=get!action=@tm.forwardUrl@ %label!for=openid OpenID: $ %input#$ident$!type=text!name=$name$!value="http://" diff --git a/Yesod/Helpers/Auth/Rpxnow.hs b/Yesod/Helpers/Auth/Rpxnow.hs index 321f1caa..a831ecf7 100644 --- a/Yesod/Helpers/Auth/Rpxnow.hs +++ b/Yesod/Helpers/Auth/Rpxnow.hs @@ -17,7 +17,7 @@ authRpxnow app apiKey = where login tm = do let url = {- FIXME urlEncode $ -} tm $ PluginR "rpxnow" [] - addBody [$hamlet| + addHamlet [$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 From b1e405beb8086acc84264b1e8f5b3e6816df2f73 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 26 Oct 2010 09:45:16 +0200 Subject: [PATCH 23/69] utf8-string -> text --- Yesod/Helpers/Auth/Email.hs | 8 ++++++-- yesod-auth.cabal | 2 +- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/Yesod/Helpers/Auth/Email.hs b/Yesod/Helpers/Auth/Email.hs index 581d8c9c..f9c50673 100644 --- a/Yesod/Helpers/Auth/Email.hs +++ b/Yesod/Helpers/Auth/Email.hs @@ -13,7 +13,8 @@ import System.Random import Control.Monad (when) import Control.Applicative ((<$>), (<*>)) import Data.Digest.Pure.MD5 -import qualified Data.ByteString.Lazy.UTF8 as LU +import qualified Data.Text.Lazy as T +import Data.Text.Lazy.Encoding (encodeUtf8) login, register, setpass :: AuthRoute login = PluginR "email" ["login"] @@ -239,7 +240,10 @@ saltPass pass = do return $ saltPass' salt pass saltPass' :: String -> String -> String -saltPass' salt pass = salt ++ show (md5 $ LU.fromString $ salt ++ pass) +saltPass' salt pass = + salt ++ show (md5 $ fromString $ salt ++ pass) + where + fromString = encodeUtf8 . T.pack isValidPass :: String -- ^ cleartext password -> SaltedPass -- ^ salted password diff --git a/yesod-auth.cabal b/yesod-auth.cabal index f47b04b3..a11f8ab1 100644 --- a/yesod-auth.cabal +++ b/yesod-auth.cabal @@ -22,7 +22,7 @@ library , random >= 1.0 && < 1.1 , data-object >= 0.3.1.3 && < 0.4 , control-monad-attempt >= 0.3.0 && < 0.4 - , utf8-string >= 0.3.4 && < 0.4 + , text >= 0.7 && < 0.11 , blaze-builder >= 0.1 && < 0.2 , mime-mail >= 0.0 && < 0.1 exposed-modules: Yesod.Helpers.Auth From 5894cc0fbd5df06d698fa9915c630ce3fb699985 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 10 Nov 2010 13:47:26 +0200 Subject: [PATCH 24/69] Remove blaze-builder dep (unneeded) --- yesod-auth.cabal | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/yesod-auth.cabal b/yesod-auth.cabal index a11f8ab1..676cac7c 100644 --- a/yesod-auth.cabal +++ b/yesod-auth.cabal @@ -1,5 +1,5 @@ name: yesod-auth -version: 0.2.0 +version: 0.2.0.1 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -23,7 +23,6 @@ library , data-object >= 0.3.1.3 && < 0.4 , control-monad-attempt >= 0.3.0 && < 0.4 , text >= 0.7 && < 0.11 - , blaze-builder >= 0.1 && < 0.2 , mime-mail >= 0.0 && < 0.1 exposed-modules: Yesod.Helpers.Auth Yesod.Helpers.Auth.Dummy From e6c3fdf15f45db69744034efecac0746fe0f265d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 22 Nov 2010 22:20:16 +0200 Subject: [PATCH 25/69] GHC 7 --- Yesod/Helpers/Auth.hs | 26 +++++++++++--- Yesod/Helpers/Auth/Dummy.hs | 8 ++++- Yesod/Helpers/Auth/Email.hs | 63 +++++++++++++++++++++++----------- Yesod/Helpers/Auth/Facebook.hs | 8 ++++- Yesod/Helpers/Auth/OpenId.hs | 17 +++++++-- Yesod/Helpers/Auth/Rpxnow.hs | 8 ++++- yesod-auth.cabal | 12 +++++-- 7 files changed, 109 insertions(+), 33 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 111be0f4..80e0b6b3 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} module Yesod.Helpers.Auth ( -- * Subsite Auth @@ -73,11 +74,17 @@ class Yesod m => YesodAuth m where mkYesodSub "Auth" [ ClassP ''YesodAuth [VarT $ mkName "master"] - ] [$parseRoutes| + ] +#define STRINGS *Strings +#if GHC7 + [parseRoutes| +#else + [$parseRoutes| +#endif /check CheckR GET /login LoginR GET /logout LogoutR GET POST -/page/#String/*Strings PluginR +/page/#String/STRINGS PluginR |] credsKey :: String @@ -94,7 +101,13 @@ setCreds doRedirects creds = do then do case authRoute y of Nothing -> do - rh <- defaultLayout [$hamlet|%h1 Invalid login|] + rh <- defaultLayout +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif + %h1 Invalid login|] sendResponse rh Just ar -> do setMessage $ string "Invalid login" @@ -115,7 +128,12 @@ getCheckR = do setTitle $ string "Authentication Status" addHtml $ html creds) (json creds) where - html creds = [$hamlet| + html creds = +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %h1 Authentication Status $maybe creds _ %p Logged in. diff --git a/Yesod/Helpers/Auth/Dummy.hs b/Yesod/Helpers/Auth/Dummy.hs index 03bc7fd9..7fbfec90 100644 --- a/Yesod/Helpers/Auth/Dummy.hs +++ b/Yesod/Helpers/Auth/Dummy.hs @@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE CPP #-} -- | Provides a dummy authentication module that simply lets a user specify -- his/her identifier. This is not intended for real world use, just for -- testing. @@ -18,7 +19,12 @@ authDummy = setCreds True $ Creds "dummy" ident [] dispatch _ _ = notFound url = PluginR "dummy" [] - login authToMaster = [$hamlet| + login authToMaster = +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %form!method=post!action=@authToMaster.url@ Your new identifier is: $ %input!type=text!name=ident diff --git a/Yesod/Helpers/Auth/Email.hs b/Yesod/Helpers/Auth/Email.hs index f9c50673..754b1d6b 100644 --- a/Yesod/Helpers/Auth/Email.hs +++ b/Yesod/Helpers/Auth/Email.hs @@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies #-} +{-# LANGUAGE CPP #-} module Yesod.Helpers.Auth.Email ( authEmail , YesodAuthEmail (..) @@ -62,22 +63,12 @@ class YesodAuth m => YesodAuthEmail m where authEmail :: YesodAuthEmail m => AuthPlugin m authEmail = - AuthPlugin "email" dispatch login' - where - go x = x >>= sendResponse - dispatch "GET" ["register"] = go getRegisterR - dispatch "POST" ["register"] = go postRegisterR - dispatch "GET" ["verify", eid, verkey] = do - y <- getYesod - case readAuthEmailId y eid of - Nothing -> notFound - Just eid' -> go $ getVerifyR eid' verkey - dispatch "POST" ["login"] = go postLoginR - dispatch "GET" ["set-password"] = go getPasswordR - dispatch "POST" ["set-password"] = go postPasswordR - dispatch _ _ = notFound - - login' tm = [$hamlet| + AuthPlugin "email" dispatch $ \tm -> +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %form!method=post!action=@tm.login@ %table %tr @@ -93,13 +84,30 @@ authEmail = %input!type=submit!value="Login via email" %a!href=@tm.register@ I don't have an account |] + where + dispatch "GET" ["register"] = getRegisterR >>= sendResponse + dispatch "POST" ["register"] = postRegisterR >>= sendResponse + dispatch "GET" ["verify", eid, verkey] = do + y <- getYesod + case readAuthEmailId y eid of + Nothing -> notFound + Just eid' -> getVerifyR eid' verkey >>= sendResponse + dispatch "POST" ["login"] = postLoginR >>= sendResponse + dispatch "GET" ["set-password"] = getPasswordR >>= sendResponse + dispatch "POST" ["set-password"] = postPasswordR >>= sendResponse + dispatch _ _ = notFound getRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml getRegisterR = do toMaster <- getRouteToMaster defaultLayout $ do setTitle $ string "Register a new account" - addHamlet [$hamlet| + addHamlet +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %p Enter your e-mail address below, and a confirmation e-mail will be sent to you. %form!method=post!action=@toMaster.register@ %label!for=email E-mail @@ -129,7 +137,12 @@ postRegisterR = do sendVerifyEmail email verKey verUrl defaultLayout $ do setTitle $ string "Confirmation e-mail sent" - addWidget [$hamlet| + addWidget +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %p A confirmation e-mail has been sent to $email$. |] @@ -151,7 +164,12 @@ getVerifyR lid key = do _ -> return () defaultLayout $ do setTitle $ string "Invalid verification key" - addHtml [$hamlet| + addHtml +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %p I'm sorry, but that was an invalid verification key. |] @@ -191,7 +209,12 @@ getPasswordR = do redirect RedirectTemporary $ toMaster login defaultLayout $ do setTitle $ string "Set password" - addHamlet [$hamlet| + addHamlet +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %h3 Set a new password %form!method=post!action=@toMaster.setpass@ %table diff --git a/Yesod/Helpers/Auth/Facebook.hs b/Yesod/Helpers/Auth/Facebook.hs index 0a4b9388..5f3e9aad 100644 --- a/Yesod/Helpers/Auth/Facebook.hs +++ b/Yesod/Helpers/Auth/Facebook.hs @@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE CPP #-} module Yesod.Helpers.Auth.Facebook ( authFacebook , facebookUrl @@ -53,7 +54,12 @@ authFacebook cid secret perms = render <- liftHandler getUrlRender let fb = Facebook.Facebook cid secret $ render $ tm url let furl = Facebook.getForwardUrl fb $ perms - addHtml [$hamlet| + addHtml +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %p %a!href=$furl$ Login with Facebook |] diff --git a/Yesod/Helpers/Auth/OpenId.hs b/Yesod/Helpers/Auth/OpenId.hs index 62d0b7bf..abc73c8e 100644 --- a/Yesod/Helpers/Auth/OpenId.hs +++ b/Yesod/Helpers/Auth/OpenId.hs @@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE CPP #-} module Yesod.Helpers.Auth.OpenId ( authOpenId , forwardUrl @@ -20,12 +21,22 @@ authOpenId = name = "openid_identifier" login tm = do ident <- newIdent - addCassius [$cassius| -#$ident$ + addCassius +#if GHC7 + [cassius| +#else + [$cassius| +#endif + #$ident$ background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%; padding-left: 18px; |] - addHamlet [$hamlet| + addHamlet +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %form!method=get!action=@tm.forwardUrl@ %label!for=openid OpenID: $ %input#$ident$!type=text!name=$name$!value="http://" diff --git a/Yesod/Helpers/Auth/Rpxnow.hs b/Yesod/Helpers/Auth/Rpxnow.hs index a831ecf7..8b6c887f 100644 --- a/Yesod/Helpers/Auth/Rpxnow.hs +++ b/Yesod/Helpers/Auth/Rpxnow.hs @@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE CPP #-} module Yesod.Helpers.Auth.Rpxnow ( authRpxnow ) where @@ -17,7 +18,12 @@ authRpxnow app apiKey = where login tm = do let url = {- FIXME urlEncode $ -} tm $ PluginR "rpxnow" [] - addHamlet [$hamlet| + addHamlet +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %iframe!src="http://$app$.rpxnow.com/openid/embed?token_url=@url@"!scrolling=no!frameBorder=no!allowtransparency=true!style="width:400px;height:240px" |] dispatch _ [] = do diff --git a/yesod-auth.cabal b/yesod-auth.cabal index 676cac7c..55f3a3f8 100644 --- a/yesod-auth.cabal +++ b/yesod-auth.cabal @@ -1,5 +1,5 @@ name: yesod-auth -version: 0.2.0.1 +version: 0.2.0.2 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -11,9 +11,15 @@ cabal-version: >= 1.6 build-type: Simple homepage: http://docs.yesodweb.com/ +flag ghc7 + library - build-depends: base >= 4 && < 5 - , authenticate >= 0.7 && < 0.8 + if flag(ghc7) + build-depends: base >= 4.3 && < 5 + cpp-options: -DGHC7 + else + build-depends: base >= 4 && < 4.3 + build-depends: authenticate >= 0.7 && < 0.8 , bytestring >= 0.9.1.4 && < 0.10 , yesod >= 0.6 && < 0.7 , wai >= 0.2 && < 0.3 From 0eecb347d924e74f9552da59e137eb779e07908e Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 30 Nov 2010 09:12:59 +0200 Subject: [PATCH 26/69] Login correctly uses redirectUltDest --- Yesod/Helpers/Auth.hs | 2 +- yesod-auth.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 80e0b6b3..55451476 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -118,7 +118,7 @@ setCreds doRedirects creds = do if doRedirects then do setMessage $ string "You are now logged in" - redirect RedirectTemporary $ loginDest y + redirectUltDest RedirectTemporary $ loginDest y else return () getCheckR :: YesodAuth m => GHandler Auth m RepHtmlJson diff --git a/yesod-auth.cabal b/yesod-auth.cabal index 55f3a3f8..776caf1f 100644 --- a/yesod-auth.cabal +++ b/yesod-auth.cabal @@ -1,5 +1,5 @@ name: yesod-auth -version: 0.2.0.2 +version: 0.2.0.3 license: BSD3 license-file: LICENSE author: Michael Snoyman From 16a23f4625a97d747709845c00f07267b4f1c1e4 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 30 Nov 2010 20:44:47 +0200 Subject: [PATCH 27/69] text 0.11 --- yesod-auth.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-auth.cabal b/yesod-auth.cabal index 776caf1f..df45e1b7 100644 --- a/yesod-auth.cabal +++ b/yesod-auth.cabal @@ -28,7 +28,7 @@ library , random >= 1.0 && < 1.1 , data-object >= 0.3.1.3 && < 0.4 , control-monad-attempt >= 0.3.0 && < 0.4 - , text >= 0.7 && < 0.11 + , text >= 0.7 && < 0.12 , mime-mail >= 0.0 && < 0.1 exposed-modules: Yesod.Helpers.Auth Yesod.Helpers.Auth.Dummy From 1cae68debce616bbf98ff4e650f48ddc32a3fec0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 26 Dec 2010 10:22:00 +0200 Subject: [PATCH 28/69] Migrate to yesod-core 0.7 --- Yesod/Helpers/Auth.hs | 20 +++++++++++++++++--- Yesod/Helpers/Auth/Dummy.hs | 4 +++- Yesod/Helpers/Auth/Email.hs | 10 +++++++++- Yesod/Helpers/Auth/Facebook.hs | 7 ++++++- Yesod/Helpers/Auth/OpenId.hs | 14 +++++++++++--- Yesod/Helpers/Auth/Rpxnow.hs | 7 ++++++- yesod-auth.cabal | 21 +++++++++++++++------ 7 files changed, 67 insertions(+), 16 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 55451476..480ee16b 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -21,10 +21,22 @@ module Yesod.Helpers.Auth , requireAuth ) where -import Yesod +import Yesod.Handler +import Yesod.Core +import Yesod.Widget +import Yesod.Content +import Yesod.Dispatch +import Yesod.Persist +import Yesod.Request +import Yesod.Json +import Text.Blaze import Language.Haskell.TH.Syntax hiding (lift) import qualified Data.ByteString.Char8 as S8 import qualified Network.Wai as W +import Text.Hamlet (hamlet) +import Data.Text.Lazy (pack) +import Data.JSON.Types (Value (..), Atom (AtomBoolean)) +import qualified Data.Map as Map data Auth = Auth @@ -141,8 +153,10 @@ $nothing %p Not logged in. |] json creds = - jsonMap - [ ("logged_in", jsonScalar $ maybe "false" (const "true") creds) + ValueObject $ Map.fromList + [ (pack "logged_in" + , ValueAtom $ AtomBoolean + $ maybe False (const True) creds) ] getLoginR :: YesodAuth m => GHandler Auth m RepHtml diff --git a/Yesod/Helpers/Auth/Dummy.hs b/Yesod/Helpers/Auth/Dummy.hs index 7fbfec90..63cc92de 100644 --- a/Yesod/Helpers/Auth/Dummy.hs +++ b/Yesod/Helpers/Auth/Dummy.hs @@ -7,8 +7,10 @@ module Yesod.Helpers.Auth.Dummy ( authDummy ) where -import Yesod import Yesod.Helpers.Auth +import Yesod.Form (runFormPost', stringInput) +import Yesod.Handler (notFound) +import Text.Hamlet (hamlet) authDummy :: YesodAuth m => AuthPlugin m authDummy = diff --git a/Yesod/Helpers/Auth/Email.hs b/Yesod/Helpers/Auth/Email.hs index 754b1d6b..9cbd8b97 100644 --- a/Yesod/Helpers/Auth/Email.hs +++ b/Yesod/Helpers/Auth/Email.hs @@ -7,7 +7,6 @@ module Yesod.Helpers.Auth.Email , saltPass ) where -import Yesod import Network.Mail.Mime (randomString) import Yesod.Helpers.Auth import System.Random @@ -17,6 +16,15 @@ import Data.Digest.Pure.MD5 import qualified Data.Text.Lazy as T import Data.Text.Lazy.Encoding (encodeUtf8) +import Yesod.Form +import Yesod.Handler +import Yesod.Content +import Yesod.Widget +import Yesod.Core +import Text.Hamlet (hamlet) +import Text.Blaze (string) +import Control.Monad.IO.Class (liftIO) + login, register, setpass :: AuthRoute login = PluginR "email" ["login"] register = PluginR "email" ["register"] diff --git a/Yesod/Helpers/Auth/Facebook.hs b/Yesod/Helpers/Auth/Facebook.hs index 5f3e9aad..07ebfd9d 100644 --- a/Yesod/Helpers/Auth/Facebook.hs +++ b/Yesod/Helpers/Auth/Facebook.hs @@ -5,12 +5,17 @@ module Yesod.Helpers.Auth.Facebook , facebookUrl ) where -import Yesod import Yesod.Helpers.Auth import qualified Web.Authenticate.Facebook as Facebook import Data.Object (fromMapping, lookupScalar) import Data.Maybe (fromMaybe) +import Yesod.Form +import Yesod.Handler +import Yesod.Widget +import Text.Hamlet (hamlet) +import Control.Monad.IO.Class (liftIO) + facebookUrl :: AuthRoute facebookUrl = PluginR "facebook" ["forward"] diff --git a/Yesod/Helpers/Auth/OpenId.hs b/Yesod/Helpers/Auth/OpenId.hs index abc73c8e..cfbc949b 100644 --- a/Yesod/Helpers/Auth/OpenId.hs +++ b/Yesod/Helpers/Auth/OpenId.hs @@ -5,11 +5,19 @@ module Yesod.Helpers.Auth.OpenId , forwardUrl ) where -import Yesod import Yesod.Helpers.Auth import qualified Web.Authenticate.OpenId as OpenId import Control.Monad.Attempt +import Yesod.Form +import Yesod.Handler +import Yesod.Widget +import Yesod.Request +import Text.Hamlet (hamlet) +import Text.Cassius (cassius) +import Text.Blaze (string) +import Control.Monad.IO.Class (liftIO) + forwardUrl :: AuthRoute forwardUrl = PluginR "openid" ["forward"] @@ -49,7 +57,7 @@ authOpenId = render <- getUrlRender toMaster <- getRouteToMaster let complete' = render $ toMaster complete - res <- runAttemptT $ OpenId.getForwardUrl oid complete' + res <- runAttemptT $ OpenId.getForwardUrl oid complete' Nothing [] attempt (\err -> do setMessage $ string $ show err @@ -77,6 +85,6 @@ completeHelper gets' = do let onFailure err = do setMessage $ string $ show err redirect RedirectTemporary $ toMaster LoginR - let onSuccess (OpenId.Identifier ident) = + let onSuccess (OpenId.Identifier ident, _) = setCreds True $ Creds "openid" ident [] attempt onFailure onSuccess res diff --git a/Yesod/Helpers/Auth/Rpxnow.hs b/Yesod/Helpers/Auth/Rpxnow.hs index 8b6c887f..defe0211 100644 --- a/Yesod/Helpers/Auth/Rpxnow.hs +++ b/Yesod/Helpers/Auth/Rpxnow.hs @@ -4,11 +4,16 @@ module Yesod.Helpers.Auth.Rpxnow ( authRpxnow ) where -import Yesod import Yesod.Helpers.Auth import qualified Web.Authenticate.Rpxnow as Rpxnow import Control.Monad (mplus) +import Yesod.Handler +import Yesod.Widget +import Yesod.Request +import Text.Hamlet (hamlet) +import Control.Monad.IO.Class (liftIO) + authRpxnow :: YesodAuth m => String -- ^ app name -> String -- ^ key diff --git a/yesod-auth.cabal b/yesod-auth.cabal index df45e1b7..c2a9fc55 100644 --- a/yesod-auth.cabal +++ b/yesod-auth.cabal @@ -1,11 +1,11 @@ name: yesod-auth -version: 0.2.0.3 +version: 0.3.0 license: BSD3 license-file: LICENSE author: Michael Snoyman maintainer: Michael Snoyman synopsis: Authentication for Yesod. -category: Web +category: Web, Yesod stability: Stable cabal-version: >= 1.6 build-type: Simple @@ -19,17 +19,26 @@ library cpp-options: -DGHC7 else build-depends: base >= 4 && < 4.3 - build-depends: authenticate >= 0.7 && < 0.8 + build-depends: authenticate >= 0.8 && < 0.9 , bytestring >= 0.9.1.4 && < 0.10 - , yesod >= 0.6 && < 0.7 - , wai >= 0.2 && < 0.3 + , yesod-core >= 0.7 && < 0.8 + , wai >= 0.3 && < 0.4 , template-haskell , pureMD5 >= 1.1 && < 2.2 , random >= 1.0 && < 1.1 , data-object >= 0.3.1.3 && < 0.4 , control-monad-attempt >= 0.3.0 && < 0.4 , text >= 0.7 && < 0.12 - , mime-mail >= 0.0 && < 0.1 + , mime-mail >= 0.1 && < 0.2 + , blaze-html >= 0.3.0.4 && < 0.4 + , yesod-persistent >= 0.0 && < 0.1 + , hamlet >= 0.7 && < 0.8 + , yesod-json >= 0.0 && < 0.1 + , containers >= 0.2 && < 0.5 + , json-types >= 0.1 && < 0.2 + , text >= 0.11 && < 0.12 + , yesod-form >= 0.0 && < 0.1 + , transformers >= 0.2 && < 0.3 exposed-modules: Yesod.Helpers.Auth Yesod.Helpers.Auth.Dummy Yesod.Helpers.Auth.Email From 6a8fdafb0604edb5f14ec0c2d2024f6fce598eec Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sat, 1 Jan 2011 20:17:35 +0200 Subject: [PATCH 29/69] OpenId label has correct for value --- Yesod/Helpers/Auth/OpenId.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Yesod/Helpers/Auth/OpenId.hs b/Yesod/Helpers/Auth/OpenId.hs index cfbc949b..0ae1668a 100644 --- a/Yesod/Helpers/Auth/OpenId.hs +++ b/Yesod/Helpers/Auth/OpenId.hs @@ -46,7 +46,7 @@ authOpenId = [$hamlet| #endif %form!method=get!action=@tm.forwardUrl@ - %label!for=openid OpenID: $ + %label!for=$ident$ OpenID: $ %input#$ident$!type=text!name=$name$!value="http://" %input!type=submit!value="Login via OpenID" |] From 38fb60ffa10ddadfb11e378a72004516291146a4 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 13 Jan 2011 22:55:21 +0200 Subject: [PATCH 30/69] yesod-core changes --- Yesod/Helpers/Auth/OpenId.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Yesod/Helpers/Auth/OpenId.hs b/Yesod/Helpers/Auth/OpenId.hs index 0ae1668a..8dc28914 100644 --- a/Yesod/Helpers/Auth/OpenId.hs +++ b/Yesod/Helpers/Auth/OpenId.hs @@ -16,7 +16,7 @@ import Yesod.Request import Text.Hamlet (hamlet) import Text.Cassius (cassius) import Text.Blaze (string) -import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Class (lift) forwardUrl :: AuthRoute forwardUrl = PluginR "openid" ["forward"] @@ -74,7 +74,7 @@ authOpenId = completeHelper $ reqGetParams rr dispatch "POST" ["complete"] = do rr <- getRequest - (posts, _) <- liftIO $ reqRequestBody rr + (posts, _) <- lift $ reqRequestBody rr completeHelper posts dispatch _ _ = notFound From 4320ca990dd4a9daff02303446122745372fb9c7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 14 Jan 2011 00:23:09 +0200 Subject: [PATCH 31/69] Customized messages --- Yesod/Helpers/Auth.hs | 47 ++++++++++++++++++++++++++++++ Yesod/Helpers/Auth/Email.hs | 52 ++++++++++++++++++---------------- Yesod/Helpers/Auth/Facebook.hs | 3 +- Yesod/Helpers/Auth/OpenId.hs | 6 ++-- 4 files changed, 81 insertions(+), 27 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 480ee16b..e7939043 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -84,6 +84,53 @@ class Yesod m => YesodAuth m where tm <- liftHandler getRouteToMaster mapM_ (flip apLogin tm) authPlugins + ----- Message strings. In theory in the future make this localizable + ----- See gist: https://gist.github.com/778712 + messageNoOpenID :: m -> Html + messageNoOpenID _ = string "No OpenID identifier found" + messageLoginOpenID :: m -> Html + messageLoginOpenID _ = string "Login via OpenID" + + messageEmail :: m -> Html + messageEmail _ = string "Email" + messagePassword :: m -> Html + messagePassword _ = string "Password" + messageRegister :: m -> Html + messageRegister _ = string "Register" + messageRegisterLong :: m -> Html + messageRegisterLong _ = string "Register a new account" + messageEnterEmail :: m -> Html + messageEnterEmail _ = string "Enter your e-mail address below, and a confirmation e-mail will be sent to you." + messageConfirmationEmailSentTitle :: m -> Html + messageConfirmationEmailSentTitle _ = string "Confirmation e-mail sent" + messageConfirmationEmailSent :: m -> String -> Html + messageConfirmationEmailSent _ email = string $ "A confirmation e-mail has been sent to " ++ email ++ "." + messageAddressVerified :: m -> Html + messageAddressVerified _ = string "Address verified, please set a new password" + messageInvalidKeyTitle :: m -> Html + messageInvalidKeyTitle _ = string "Invalid verification key" + messageInvalidKey :: m -> Html + messageInvalidKey _ = string "I'm sorry, but that was an invalid verification key." + messageInvalidEmailPass :: m -> Html + messageInvalidEmailPass _ = string "Invalid email/password combination" + messageBadSetPass :: m -> Html + messageBadSetPass _ = string "You must be logged in to set a password" + messageSetPassTitle :: m -> Html + messageSetPassTitle _ = string "Set password" + messageSetPass :: m -> Html + messageSetPass _ = string "Set a new password" + messageNewPass :: m -> Html + messageNewPass _ = string "New password" + messageConfirmPass :: m -> Html + messageConfirmPass _ = string "Confirm" + messagePassMismatch :: m -> Html + messagePassMismatch _ = string "Passwords did not match, please try again" + messagePassUpdated :: m -> Html + messagePassUpdated _ = string "Password updated" + + messageFacebook :: m -> Html + messageFacebook _ = string "Login with Facebook" + mkYesodSub "Auth" [ ClassP ''YesodAuth [VarT $ mkName "master"] ] diff --git a/Yesod/Helpers/Auth/Email.hs b/Yesod/Helpers/Auth/Email.hs index 9cbd8b97..7bb31ab8 100644 --- a/Yesod/Helpers/Auth/Email.hs +++ b/Yesod/Helpers/Auth/Email.hs @@ -22,7 +22,6 @@ import Yesod.Content import Yesod.Widget import Yesod.Core import Text.Hamlet (hamlet) -import Text.Blaze (string) import Control.Monad.IO.Class (liftIO) login, register, setpass :: AuthRoute @@ -71,7 +70,8 @@ class YesodAuth m => YesodAuthEmail m where authEmail :: YesodAuthEmail m => AuthPlugin m authEmail = - AuthPlugin "email" dispatch $ \tm -> + AuthPlugin "email" dispatch $ \tm -> do + y <- liftHandler getYesod #if GHC7 [hamlet| #else @@ -80,11 +80,11 @@ authEmail = %form!method=post!action=@tm.login@ %table %tr - %th E-mail + %th $messageEmail.y$ %td %input!type=email!name=email %tr - %th Password + %th $messagePassword.y$ %td %input!type=password!name=password %tr @@ -107,20 +107,21 @@ authEmail = getRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml getRegisterR = do + y <- getYesod toMaster <- getRouteToMaster defaultLayout $ do - setTitle $ string "Register a new account" + setTitle $ messageRegisterLong y addHamlet #if GHC7 [hamlet| #else [$hamlet| #endif -%p Enter your e-mail address below, and a confirmation e-mail will be sent to you. +%p $messageEnterEmail.y$ %form!method=post!action=@toMaster.register@ - %label!for=email E-mail + %label!for=email $messageEmail y$ %input!type=email!name=email!width=150 - %input!type=submit!value=Register + %input!type=submit!value=$messageRegister y$ |] postRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml @@ -144,14 +145,14 @@ postRegisterR = do let verUrl = render $ tm $ verify (showAuthEmailId y lid) verKey sendVerifyEmail email verKey verUrl defaultLayout $ do - setTitle $ string "Confirmation e-mail sent" + setTitle $ messageConfirmationEmailSentTitle y addWidget #if GHC7 [hamlet| #else [$hamlet| #endif -%p A confirmation e-mail has been sent to $email$. +%p $(messageConfirmationEmailSent y) email$ |] getVerifyR :: YesodAuthEmail m @@ -159,6 +160,7 @@ getVerifyR :: YesodAuthEmail m getVerifyR lid key = do realKey <- getVerifyKey lid memail <- getEmail lid + y <- getYesod case (realKey == Just key, memail) of (True, Just email) -> do muid <- verifyAccount lid @@ -167,18 +169,18 @@ getVerifyR lid key = do Just _uid -> do setCreds False $ Creds "email" email [("verifiedEmail", email)] -- FIXME uid? toMaster <- getRouteToMaster - setMessage $ string "Address verified, please set a new password" + setMessage $ messageAddressVerified y redirect RedirectTemporary $ toMaster setpass _ -> return () defaultLayout $ do - setTitle $ string "Invalid verification key" + setTitle $ messageInvalidKey y addHtml #if GHC7 [hamlet| #else [$hamlet| #endif -%p I'm sorry, but that was an invalid verification key. +%p $messageInvalidKey y$ |] postLoginR :: YesodAuthEmail master => GHandler Auth master () @@ -202,7 +204,8 @@ postLoginR = do Just _aid -> setCreds True $ Creds "email" email [("verifiedEmail", email)] -- FIXME aid? Nothing -> do - setMessage $ string "Invalid email/password combination" + y <- getYesod + setMessage $ messageInvalidEmailPass y toMaster <- getRouteToMaster redirect RedirectTemporary $ toMaster LoginR @@ -210,33 +213,34 @@ getPasswordR :: YesodAuthEmail master => GHandler Auth master RepHtml getPasswordR = do toMaster <- getRouteToMaster maid <- maybeAuthId + y <- getYesod case maid of Just _ -> return () Nothing -> do - setMessage $ string "You must be logged in to set a password" + setMessage $ messageBadSetPass y redirect RedirectTemporary $ toMaster login defaultLayout $ do - setTitle $ string "Set password" + setTitle $ messageSetPassTitle y addHamlet #if GHC7 [hamlet| #else [$hamlet| #endif -%h3 Set a new password +%h3 $messageSetPass y$ %form!method=post!action=@toMaster.setpass@ %table %tr - %th New password + %th $messageNewPass y$ %td %input!type=password!name=new %tr - %th Confirm + %th $messageConfirmPass y$ %td %input!type=password!name=confirm %tr %td!colspan=2 - %input!type=submit!value=Submit + %input!type=submit!value=$messageSetPassTitle y$ |] postPasswordR :: YesodAuthEmail master => GHandler Auth master () @@ -245,19 +249,19 @@ postPasswordR = do <$> stringInput "new" <*> stringInput "confirm" toMaster <- getRouteToMaster + y <- getYesod when (new /= confirm) $ do - setMessage $ string "Passwords did not match, please try again" + setMessage $ messagePassMismatch y redirect RedirectTemporary $ toMaster setpass maid <- maybeAuthId aid <- case maid of Nothing -> do - setMessage $ string "You must be logged in to set a password" + setMessage $ messageBadSetPass y redirect RedirectTemporary $ toMaster login Just aid -> return aid salted <- liftIO $ saltPass new setPassword aid salted - setMessage $ string "Password updated" - y <- getYesod + setMessage $ messagePassUpdated y redirect RedirectTemporary $ loginDest y saltLength :: Int diff --git a/Yesod/Helpers/Auth/Facebook.hs b/Yesod/Helpers/Auth/Facebook.hs index 07ebfd9d..4cfe7869 100644 --- a/Yesod/Helpers/Auth/Facebook.hs +++ b/Yesod/Helpers/Auth/Facebook.hs @@ -59,6 +59,7 @@ authFacebook cid secret perms = render <- liftHandler getUrlRender let fb = Facebook.Facebook cid secret $ render $ tm url let furl = Facebook.getForwardUrl fb $ perms + y <- liftHandler getYesod addHtml #if GHC7 [hamlet| @@ -66,5 +67,5 @@ authFacebook cid secret perms = [$hamlet| #endif %p - %a!href=$furl$ Login with Facebook + %a!href=$furl$ $messageFacebook y$ |] diff --git a/Yesod/Helpers/Auth/OpenId.hs b/Yesod/Helpers/Auth/OpenId.hs index 8dc28914..5560601a 100644 --- a/Yesod/Helpers/Auth/OpenId.hs +++ b/Yesod/Helpers/Auth/OpenId.hs @@ -29,6 +29,7 @@ authOpenId = name = "openid_identifier" login tm = do ident <- newIdent + y <- liftHandler getYesod addCassius #if GHC7 [cassius| @@ -48,10 +49,11 @@ authOpenId = %form!method=get!action=@tm.forwardUrl@ %label!for=$ident$ OpenID: $ %input#$ident$!type=text!name=$name$!value="http://" - %input!type=submit!value="Login via OpenID" + %input!type=submit!value=$messageLoginOpenID.y$ |] dispatch "GET" ["forward"] = do (roid, _, _) <- runFormGet $ stringInput name + y <- getYesod case roid of FormSuccess oid -> do render <- getUrlRender @@ -67,7 +69,7 @@ authOpenId = res _ -> do toMaster <- getRouteToMaster - setMessage $ string "No OpenID identifier found" + setMessage $ messageNoOpenID y redirect RedirectTemporary $ toMaster LoginR dispatch "GET" ["complete"] = do rr <- getRequest From 6ab1bf4ce6766dc07210025cf834a3a1678be569 Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Sat, 15 Jan 2011 18:38:21 -0500 Subject: [PATCH 32/69] Added Yesod.Helpers.Auth.HashDB --- Yesod/Helpers/Auth/HashDB.hs | 177 +++++++++++++++++++++++++++++++++++ 1 file changed, 177 insertions(+) create mode 100644 Yesod/Helpers/Auth/HashDB.hs diff --git a/Yesod/Helpers/Auth/HashDB.hs b/Yesod/Helpers/Auth/HashDB.hs new file mode 100644 index 00000000..86673107 --- /dev/null +++ b/Yesod/Helpers/Auth/HashDB.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +------------------------------------------------------------------------------- +-- | +-- Module : Yesod.Helpers.Auth.HashDB +-- Copyright : (c) Patrick Brisbin 2010 +-- License : as-is +-- +-- Maintainer : pbrisbin@gmail.com +-- Stability : Stable +-- 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. +-- +-- Example usage: +-- +-- > -- import the function +-- > import Helpers.Auth.HashDB +-- > +-- > -- make sure you have an auth route +-- > mkYesodData "MyApp" [$parseRoutes| +-- > / RootR GET +-- > /auth AuthR Auth getAuth +-- > |] +-- > +-- > +-- > -- make your app an instance of YesodAuth using this plugin +-- > instance YesodAuth MyApp where +-- > type AuthId MyApp = UserId +-- > +-- > loginDest _ = RootR +-- > logoutDest _ = RootR +-- > getAuthId = getAuthIdHashDB AuthR +-- > showAuthId _ = showIntegral +-- > readAuthId _ = readIntegral +-- > authPlugins = [authHashDB] +-- > +-- > +-- > -- include the migration function in site startup +-- > withServer :: (Application -> IO a) -> IO a +-- > withServer f = withConnectionPool $ \p -> do +-- > 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. +-- +-- > echo -n 'MyPassword' | sha1sum +-- +-- can be used to get the hash from the commandline. +-- +------------------------------------------------------------------------------- +module Helpers.Auth.HashDB + ( authHashDB + , getAuthIdHashDB + , UserId + , migrateUsers + ) where + +import Yesod +import Yesod.Helpers.Auth + +import Control.Applicative ((<$>), (<*>)) +import Data.ByteString.Lazy.Char8 (pack) +import Data.Digest.Pure.SHA (sha1, showDigest) +import Database.Persist.TH (share2) +import Database.Persist.GenericSql (mkMigrate) + +-- | 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") [$persist| +User + username String Eq + password String + UniqueUser username +|] + +-- | Given a (user,password) in plaintext, validate them against the +-- database values +validateUser :: (YesodPersist y, + PersistBackend (YesodDB y (GHandler sub y))) + => (String, String) + -> 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 password == userPassword sqlUser + +login :: AuthRoute +login = PluginR "hashdb" ["login"] + +-- | Handle the login form +postLoginR :: (YesodAuth y, + YesodPersist y, + PersistBackend (YesodDB y (GHandler Auth y))) + => GHandler Auth y () +postLoginR = do + (user, password) <- runFormPost' $ (,) + <$> stringInput "username" + <*> stringInput "password" + + isValid <- validateUser (user,password) + + if isValid + then setCreds True $ Creds "hashdb" user [] + else do + setMessage $ [$hamlet| %em 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 (GHandler sub master)), + 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 + muid <- maybeAuth + case muid of + -- user already authenticated + Just (uid, _) -> return $ Just uid + Nothing -> do + x <- runDB $ getBy $ UniqueUser (credsIdent creds) + case x of + -- user exists + Just (uid, _) -> return $ Just uid + Nothing -> do + setMessage $ [$hamlet| %em 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 (GHandler Auth y))) + => AuthPlugin y +authHashDB = AuthPlugin "hashdb" dispatch $ \tm -> + [$hamlet| + #header + %h1 Login + + #login + %form!method=post!action=@tm.login@ + %table + %tr + %th Username: + %td + %input#x!name=username!autofocus + %tr + %th Password: + %td + %input!type=password!name=password + %tr + %td   + %td + %input!type=submit!value="Login" + + %script + if (!("autofocus" in document.createElement("input"))) { + document.getElementById("x").focus(); + } + |] + where + dispatch "POST" ["login"] = postLoginR >>= sendResponse + dispatch _ _ = notFound From 6c53f52417f448190273bc72c5d57ee84092a024 Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Sat, 15 Jan 2011 18:39:12 -0500 Subject: [PATCH 33/69] cabal file: added module and version bump --- yesod-auth.cabal | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/yesod-auth.cabal b/yesod-auth.cabal index c2a9fc55..9cf245cc 100644 --- a/yesod-auth.cabal +++ b/yesod-auth.cabal @@ -7,7 +7,7 @@ maintainer: Michael Snoyman synopsis: Authentication for Yesod. category: Web, Yesod stability: Stable -cabal-version: >= 1.6 +cabal-version: >= 1.6.1 build-type: Simple homepage: http://docs.yesodweb.com/ @@ -45,6 +45,7 @@ library Yesod.Helpers.Auth.Facebook Yesod.Helpers.Auth.OpenId Yesod.Helpers.Auth.Rpxnow + Yesod.Helpers.Auth.HashDB ghc-options: -Wall source-repository head From 9671a86697b94614786711b2a9572ba21c048443 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 17 Jan 2011 20:15:14 +0200 Subject: [PATCH 34/69] Added Patrick to author list --- yesod-auth.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/yesod-auth.cabal b/yesod-auth.cabal index 9cf245cc..fce8ebbe 100644 --- a/yesod-auth.cabal +++ b/yesod-auth.cabal @@ -2,12 +2,12 @@ name: yesod-auth version: 0.3.0 license: BSD3 license-file: LICENSE -author: Michael Snoyman +author: Michael Snoyman, Patrick Brisbin maintainer: Michael Snoyman synopsis: Authentication for Yesod. category: Web, Yesod stability: Stable -cabal-version: >= 1.6.1 +cabal-version: >= 1.6.0 build-type: Simple homepage: http://docs.yesodweb.com/ From 66ee5f4c96212d68f6f1d69b7e45f23bebd77fcc Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 20 Jan 2011 00:01:43 +0200 Subject: [PATCH 35/69] Fix HashDB; hamlet6to7; GGHandler IO --- Yesod/Helpers/Auth.hs | 15 +++---- Yesod/Helpers/Auth/Dummy.hs | 8 ++-- Yesod/Helpers/Auth/Email.hs | 70 ++++++++++++++++----------------- Yesod/Helpers/Auth/Facebook.hs | 4 +- Yesod/Helpers/Auth/HashDB.hs | 72 ++++++++++++++++++---------------- Yesod/Helpers/Auth/OpenId.hs | 13 +++--- Yesod/Helpers/Auth/Rpxnow.hs | 2 +- yesod-auth.cabal | 4 +- 8 files changed, 98 insertions(+), 90 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index e7939043..ef978c29 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -166,7 +166,8 @@ setCreds doRedirects creds = do #else [$hamlet| #endif - %h1 Invalid login|] +

Invalid login +|] sendResponse rh Just ar -> do setMessage $ string "Invalid login" @@ -193,11 +194,11 @@ getCheckR = do #else [$hamlet| #endif -%h1 Authentication Status -$maybe creds _ - %p Logged in. +

Authentication Status +$maybe _ <- creds +

Logged in. $nothing - %p Not logged in. +

Not logged in. |] json creds = ValueObject $ Map.fromList @@ -237,7 +238,7 @@ maybeAuthId = do maybeAuth :: ( YesodAuth m , Key val ~ AuthId m - , PersistBackend (YesodDB m (GHandler s m)) + , PersistBackend (YesodDB m (GGHandler s m IO)) , PersistEntity val , YesodPersist m ) => GHandler s m (Maybe (Key val, val)) @@ -256,7 +257,7 @@ requireAuthId = maybeAuthId >>= maybe redirectLogin return requireAuth :: ( YesodAuth m , Key val ~ AuthId m - , PersistBackend (YesodDB m (GHandler s m)) + , PersistBackend (YesodDB m (GGHandler s m IO)) , PersistEntity val , YesodPersist m ) => GHandler s m (Key val, val) diff --git a/Yesod/Helpers/Auth/Dummy.hs b/Yesod/Helpers/Auth/Dummy.hs index 63cc92de..62694026 100644 --- a/Yesod/Helpers/Auth/Dummy.hs +++ b/Yesod/Helpers/Auth/Dummy.hs @@ -27,8 +27,8 @@ authDummy = #else [$hamlet| #endif -%form!method=post!action=@authToMaster.url@ - Your new identifier is: $ - %input!type=text!name=ident - %input!type=submit!value="Dummy Login" +

+ \Your new identifier is: + + |] diff --git a/Yesod/Helpers/Auth/Email.hs b/Yesod/Helpers/Auth/Email.hs index 7bb31ab8..08a16774 100644 --- a/Yesod/Helpers/Auth/Email.hs +++ b/Yesod/Helpers/Auth/Email.hs @@ -77,20 +77,20 @@ authEmail = #else [$hamlet| #endif -%form!method=post!action=@tm.login@ - %table - %tr - %th $messageEmail.y$ - %td - %input!type=email!name=email - %tr - %th $messagePassword.y$ - %td - %input!type=password!name=password - %tr - %td!colspan=2 - %input!type=submit!value="Login via email" - %a!href=@tm.register@ I don't have an account + + + + + +
#{messageEmail y} + + +
#{messagePassword y} + + +
+ + I don't have an account |] where dispatch "GET" ["register"] = getRegisterR >>= sendResponse @@ -117,11 +117,11 @@ getRegisterR = do #else [$hamlet| #endif -%p $messageEnterEmail.y$ -%form!method=post!action=@toMaster.register@ - %label!for=email $messageEmail y$ - %input!type=email!name=email!width=150 - %input!type=submit!value=$messageRegister y$ +

#{messageEnterEmail y} + +

#{messageConfirmationEmailSent y email} |] getVerifyR :: YesodAuthEmail m @@ -180,7 +180,7 @@ getVerifyR lid key = do #else [$hamlet| #endif -%p $messageInvalidKey y$ +

#{messageInvalidKey y} |] postLoginR :: YesodAuthEmail master => GHandler Auth master () @@ -227,20 +227,20 @@ getPasswordR = do #else [$hamlet| #endif -%h3 $messageSetPass y$ -%form!method=post!action=@toMaster.setpass@ - %table - %tr - %th $messageNewPass y$ - %td - %input!type=password!name=new - %tr - %th $messageConfirmPass y$ - %td - %input!type=password!name=confirm - %tr - %td!colspan=2 - %input!type=submit!value=$messageSetPassTitle y$ +

#{messageSetPass y} + + + + + +
#{messageNewPass y} + + +
#{messageConfirmPass y} + + +
+ |] postPasswordR :: YesodAuthEmail master => GHandler Auth master () diff --git a/Yesod/Helpers/Auth/Facebook.hs b/Yesod/Helpers/Auth/Facebook.hs index 4cfe7869..3ddeb76f 100644 --- a/Yesod/Helpers/Auth/Facebook.hs +++ b/Yesod/Helpers/Auth/Facebook.hs @@ -66,6 +66,6 @@ authFacebook cid secret perms = #else [$hamlet| #endif -%p - %a!href=$furl$ $messageFacebook y$ +

+ #{messageFacebook y} |] diff --git a/Yesod/Helpers/Auth/HashDB.hs b/Yesod/Helpers/Auth/HashDB.hs index 86673107..3020c08a 100644 --- a/Yesod/Helpers/Auth/HashDB.hs +++ b/Yesod/Helpers/Auth/HashDB.hs @@ -54,15 +54,18 @@ -- can be used to get the hash from the commandline. -- ------------------------------------------------------------------------------- -module Helpers.Auth.HashDB +module Yesod.Helpers.Auth.HashDB ( authHashDB , getAuthIdHashDB , UserId , migrateUsers ) where -import Yesod +import Yesod.Persist +import Yesod.Handler +import Yesod.Form import Yesod.Helpers.Auth +import Text.Hamlet (hamlet) import Control.Applicative ((<$>), (<*>)) import Data.ByteString.Lazy.Char8 (pack) @@ -85,7 +88,7 @@ User -- | Given a (user,password) in plaintext, validate them against the -- database values validateUser :: (YesodPersist y, - PersistBackend (YesodDB y (GHandler sub y))) + PersistBackend (YesodDB y (GGHandler sub y IO))) => (String, String) -> GHandler sub y Bool validateUser (user,password) = runDB (getBy $ UniqueUser user) >>= \dbUser -> @@ -101,7 +104,7 @@ login = PluginR "hashdb" ["login"] -- | Handle the login form postLoginR :: (YesodAuth y, YesodPersist y, - PersistBackend (YesodDB y (GHandler Auth y))) + PersistBackend (YesodDB y (GGHandler Auth y IO))) => GHandler Auth y () postLoginR = do (user, password) <- runFormPost' $ (,) @@ -113,14 +116,15 @@ postLoginR = do if isValid then setCreds True $ Creds "hashdb" user [] else do - setMessage $ [$hamlet| %em invalid username/password |] + setMessage $ [$hamlet| 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 (GHandler sub master)), + PersistBackend (YesodDB master (GGHandler sub master IO)), YesodPersist master, YesodAuth master) => (AuthRoute -> Route master) -- ^ your site's Auth Route @@ -137,41 +141,43 @@ getAuthIdHashDB authR creds = do -- user exists Just (uid, _) -> return $ Just uid Nothing -> do - setMessage $ [$hamlet| %em user not found |] + setMessage $ [$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 (GHandler Auth y))) + PersistBackend (YesodDB y (GGHandler Auth y IO))) => AuthPlugin y authHashDB = AuthPlugin "hashdb" dispatch $ \tm -> - [$hamlet| - #header - %h1 Login - - #login - %form!method=post!action=@tm.login@ - %table - %tr - %th Username: - %td - %input#x!name=username!autofocus - %tr - %th Password: - %td - %input!type=password!name=password - %tr - %td   - %td - %input!type=submit!value="Login" - - %script - if (!("autofocus" in document.createElement("input"))) { - document.getElementById("x").focus(); - } - |] + [$hamlet|\ +