Authentication included in scaffolded site
This commit is contained in:
Michael Snoyman
parent
465366766b
commit
7e4ec40779
@ -35,7 +35,9 @@ module Yesod.Helpers.Auth
|
||||
, EmailSettings (..)
|
||||
, FacebookSettings (..)
|
||||
-- * Functions
|
||||
, maybeAuth
|
||||
, maybeAuthId
|
||||
, requireAuth
|
||||
, requireAuthId
|
||||
) where
|
||||
|
||||
@ -47,6 +49,7 @@ import Yesod
|
||||
import Yesod.Mail (randomString)
|
||||
|
||||
import Data.Maybe
|
||||
import Data.Int (Int64)
|
||||
import Control.Monad
|
||||
import System.Random
|
||||
import Data.Digest.Pure.MD5
|
||||
@ -56,19 +59,15 @@ import Data.ByteString.Lazy.UTF8 (fromString)
|
||||
import Data.Object
|
||||
import Language.Haskell.TH.Syntax
|
||||
|
||||
class (Integral (AuthEmailId master), Yesod master,
|
||||
Show (AuthId master), Read (AuthId master), Eq (AuthId master)
|
||||
) => YesodAuth master where
|
||||
type AuthId master
|
||||
type AuthEmailId master
|
||||
type AuthId m = Key (AuthEntity m)
|
||||
type AuthEmailId m = Key (AuthEmailEntity m)
|
||||
|
||||
showAuthId :: AuthId master -> GHandler s master String
|
||||
showAuthId = return . show
|
||||
|
||||
readAuthId :: String -> GHandler s master (Maybe (AuthId master))
|
||||
readAuthId s = return $ case reads s of
|
||||
[] -> Nothing
|
||||
((x, _):_) -> Just x
|
||||
class ( Yesod master
|
||||
, PersistEntity (AuthEntity master)
|
||||
, PersistEntity (AuthEmailEntity master)
|
||||
) => YesodAuth master where
|
||||
type AuthEntity master
|
||||
type AuthEmailEntity master
|
||||
|
||||
-- | Default destination on successful login or logout, if no other
|
||||
-- destination exists.
|
||||
@ -163,7 +162,7 @@ setCreds creds extra = do
|
||||
maid <- getAuthId creds extra
|
||||
case maid of
|
||||
Nothing -> return ()
|
||||
Just aid -> showAuthId aid >>= setSession credsKey
|
||||
Just aid -> setSession credsKey $ show $ fromPersistKey aid
|
||||
|
||||
-- | Retrieves user credentials, if user is authenticated.
|
||||
maybeAuthId :: YesodAuth m => GHandler s m (Maybe (AuthId m))
|
||||
@ -171,7 +170,23 @@ maybeAuthId = do
|
||||
ms <- lookupSession credsKey
|
||||
case ms of
|
||||
Nothing -> return Nothing
|
||||
Just s -> readAuthId s
|
||||
Just s -> case reads s of
|
||||
[] -> return Nothing
|
||||
(i, _):_ -> return $ Just $ toPersistKey i
|
||||
|
||||
maybeAuth :: ( PersistBackend (YesodDB m (GHandler s m))
|
||||
, YesodPersist m
|
||||
, YesodAuth m
|
||||
) => GHandler s m (Maybe (AuthId m, AuthEntity m))
|
||||
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)
|
||||
|
||||
mkYesodSub "Auth"
|
||||
[ ClassP ''YesodAuth [VarT $ mkName "master"]
|
||||
@ -186,7 +201,7 @@ mkYesodSub "Auth"
|
||||
/facebook FacebookR GET
|
||||
|
||||
/register EmailRegisterR GET POST
|
||||
/verify/#Integer/#String EmailVerifyR GET
|
||||
/verify/#Int64/#String EmailVerifyR GET
|
||||
/email-login EmailLoginR POST
|
||||
/set-password EmailPasswordR GET POST
|
||||
|
||||
@ -233,7 +248,7 @@ handleRpxnowR :: YesodAuth master => GHandler Auth master ()
|
||||
handleRpxnowR = do
|
||||
ay <- getYesod
|
||||
auth <- getYesod
|
||||
apiKey <- case rpxnowApp <$> rpxnowSettings auth of
|
||||
apiKey <- case rpxnowKey <$> rpxnowSettings auth of
|
||||
Just x -> return x
|
||||
Nothing -> notFound
|
||||
token1 <- lookupGetParam "token"
|
||||
@ -295,15 +310,21 @@ getLogoutR = do
|
||||
-- 'authRoute'. Sets ultimate destination to current route, so user
|
||||
-- should be sent back here after authenticating.
|
||||
requireAuthId :: YesodAuth m => GHandler sub m (AuthId m)
|
||||
requireAuthId =
|
||||
maybeAuthId >>= maybe redirectLogin return
|
||||
where
|
||||
redirectLogin = do
|
||||
y <- getYesod
|
||||
setUltDest'
|
||||
case authRoute y of
|
||||
Just z -> redirect RedirectTemporary z
|
||||
Nothing -> permissionDenied "Please configure authRoute"
|
||||
requireAuthId = maybeAuthId >>= maybe redirectLogin return
|
||||
|
||||
requireAuth :: ( PersistBackend (YesodDB m (GHandler s m))
|
||||
, YesodPersist m
|
||||
, YesodAuth m
|
||||
) => GHandler s m (AuthId m, AuthEntity m)
|
||||
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"
|
||||
|
||||
getEmailSettings :: YesodAuth master
|
||||
=> GHandler Auth master (EmailSettings master)
|
||||
@ -341,16 +362,16 @@ postEmailRegisterR = do
|
||||
return (lid, key)
|
||||
render <- getUrlRender
|
||||
tm <- getRouteToMaster
|
||||
let verUrl = render $ tm $ EmailVerifyR (fromIntegral lid) verKey
|
||||
let verUrl = render $ tm $ EmailVerifyR (fromPersistKey lid) verKey
|
||||
sendVerifyEmail ae email verKey verUrl
|
||||
defaultLayout $ setTitle "Confirmation e-mail sent" >> addBody [$hamlet|
|
||||
%p A confirmation e-mail has been sent to $email$.
|
||||
|]
|
||||
|
||||
getEmailVerifyR :: YesodAuth master
|
||||
=> Integer -> String -> GHandler Auth master RepHtml
|
||||
=> Int64 -> String -> GHandler Auth master RepHtml
|
||||
getEmailVerifyR lid' key = do
|
||||
let lid = fromInteger lid'
|
||||
let lid = toPersistKey lid'
|
||||
ae <- getEmailSettings
|
||||
realKey <- getVerifyKey ae lid
|
||||
memail <- getEmail ae lid
|
||||
|
||||
148
scaffold.hs
148
scaffold.hs
@ -173,13 +173,19 @@ module ~sitearg~
|
||||
, ~sitearg~Route (..)
|
||||
, resources~sitearg~
|
||||
, Handler
|
||||
, maybeAuth
|
||||
, requireAuth
|
||||
, module Yesod
|
||||
, module Settings
|
||||
, module Model
|
||||
, StaticRoute (..)
|
||||
, AuthRoute (..)
|
||||
) where
|
||||
|
||||
import Yesod
|
||||
import Yesod.Mail
|
||||
import Yesod.Helpers.Static
|
||||
import Yesod.Helpers.Auth
|
||||
import qualified Settings
|
||||
import System.Directory
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
@ -187,6 +193,8 @@ import Yesod.WebRoutes
|
||||
import Database.Persist.GenericSql
|
||||
import Settings (hamletFile, cassiusFile, juliusFile)
|
||||
import Model
|
||||
import Control.Monad (join)
|
||||
import Data.Maybe (isJust)
|
||||
|
||||
data ~sitearg~ = ~sitearg~
|
||||
{ getStatic :: Static
|
||||
@ -196,10 +204,13 @@ data ~sitearg~ = ~sitearg~
|
||||
type Handler = GHandler ~sitearg~ ~sitearg~
|
||||
|
||||
mkYesodData "~sitearg~" [$parseRoutes|
|
||||
/ RootR GET POST
|
||||
/static StaticR Static getStatic
|
||||
/auth AuthR Auth getAuth
|
||||
|
||||
/favicon.ico FaviconR GET
|
||||
/robots.txt RobotsR GET
|
||||
|
||||
/ RootR GET
|
||||
|~~]
|
||||
|
||||
instance Yesod ~sitearg~ where
|
||||
@ -217,6 +228,7 @@ instance Yesod ~sitearg~ where
|
||||
ss :: Site StaticRoute (String -> Maybe (GHandler Static ~sitearg~ ChooseRep))
|
||||
ss = getSubSite
|
||||
urlRenderOverride _ _ = Nothing
|
||||
authRoute _ = Just $ AuthR LoginR
|
||||
addStaticContent ext' _ content = do
|
||||
let fn = base64md5 content ++ '.' : ext'
|
||||
let statictmp = Settings.staticdir ++ "/tmp/"
|
||||
@ -227,6 +239,76 @@ instance Yesod ~sitearg~ where
|
||||
instance YesodPersist ~sitearg~ where
|
||||
type YesodDB ~sitearg~ = SqlPersist
|
||||
runDB db = fmap connPool getYesod >>= Settings.runConnectionPool db
|
||||
|
||||
instance YesodAuth ~sitearg~ where
|
||||
type AuthEntity ~sitearg~ = User
|
||||
type AuthEmailEntity ~sitearg~ = Email
|
||||
|
||||
defaultDest _ = RootR
|
||||
|
||||
getAuthId creds _extra = runDB $ do
|
||||
x <- getBy $ UniqueUser $ credsIdent creds
|
||||
case x of
|
||||
Just (uid, _) -> return $ Just uid
|
||||
Nothing -> do
|
||||
fmap Just $ insert $ User (credsIdent creds) Nothing
|
||||
|
||||
openIdEnabled _ = True
|
||||
|
||||
emailSettings _ = Just EmailSettings
|
||||
{ addUnverified = \email verkey ->
|
||||
runDB $ insert $ Email email Nothing (Just verkey)
|
||||
, sendVerifyEmail = sendVerifyEmail'
|
||||
, getVerifyKey = runDB . fmap (join . fmap emailVerkey) . get
|
||||
, setVerifyKey = \eid key -> runDB $ update eid [EmailVerkey $ Just key]
|
||||
, verifyAccount = \eid -> runDB $ do
|
||||
me <- get eid
|
||||
case me of
|
||||
Nothing -> return Nothing
|
||||
Just e -> do
|
||||
let email = emailEmail e
|
||||
case emailUser e of
|
||||
Just uid -> return $ Just uid
|
||||
Nothing -> do
|
||||
uid <- insert $ User email Nothing
|
||||
update eid [EmailUser $ Just uid]
|
||||
return $ Just uid
|
||||
, getPassword = runDB . fmap (join . fmap userPassword) . get
|
||||
, setPassword = \uid pass -> runDB $ update uid [UserPassword $ Just pass]
|
||||
, getEmailCreds = \email -> runDB $ do
|
||||
me <- getBy $ UniqueEmail email
|
||||
case me of
|
||||
Nothing -> return Nothing
|
||||
Just (eid, e) -> return $ Just EmailCreds
|
||||
{ emailCredsId = eid
|
||||
, emailCredsAuthId = emailUser e
|
||||
, emailCredsStatus = isJust $ emailUser e
|
||||
, emailCredsVerkey = emailVerkey e
|
||||
}
|
||||
, getEmail = runDB . fmap (fmap emailEmail) . get
|
||||
}
|
||||
|
||||
sendVerifyEmail' :: String -> String -> String -> GHandler Auth m ()
|
||||
sendVerifyEmail' email _ verurl =
|
||||
liftIO $ renderSendMail Mail
|
||||
{ mailHeaders =
|
||||
[ ("From", "noreply")
|
||||
, ("To", email)
|
||||
, ("Subject", "Verify your email address")
|
||||
]
|
||||
, mailPlain = verurl
|
||||
, mailParts = return Part
|
||||
{ partType = "text/html; charset=utf-8"
|
||||
, partEncoding = None
|
||||
, partDisposition = Inline
|
||||
, partContent = renderHamlet id [$hamlet|
|
||||
%p Please confirm your email address by clicking on the link below.
|
||||
%p
|
||||
%a!href=$verurl$ $verurl$
|
||||
%p Thank you
|
||||
|~~]
|
||||
}
|
||||
}
|
||||
|]
|
||||
|
||||
writeFile' "Controller.hs" [$codegen|
|
||||
@ -240,6 +322,7 @@ module Controller
|
||||
import ~sitearg~
|
||||
import Settings
|
||||
import Yesod.Helpers.Static
|
||||
import Yesod.Helpers.Auth
|
||||
import Database.Persist.GenericSql
|
||||
|
||||
import Handler.Root
|
||||
@ -255,7 +338,8 @@ getRobotsR = return $ RepPlain $ toContent "User-agent: *"
|
||||
with~sitearg~ :: (Application -> IO a) -> IO a
|
||||
with~sitearg~ f = Settings.withConnectionPool $ \p -> do
|
||||
flip runConnectionPool p $ runMigration $ do
|
||||
migrate (undefined :: Message)
|
||||
migrate (undefined :: User)
|
||||
migrate (undefined :: Email)
|
||||
let h = ~sitearg~ s p
|
||||
toWaiApp h >>= f
|
||||
where
|
||||
@ -269,30 +353,15 @@ module Handler.Root where
|
||||
import ~sitearg~
|
||||
import Control.Applicative
|
||||
|
||||
messageFormlet :: Formlet sub master Message
|
||||
messageFormlet x = fieldsToTable
|
||||
$ Message <$> textareaField "Message"
|
||||
(fmap messageContent x)
|
||||
|
||||
getRootR :: Handler RepHtml
|
||||
getRootR = do
|
||||
messages <- runDB $ selectList [] [] 10 0
|
||||
(_, wform, _) <- runFormGet $ messageFormlet Nothing
|
||||
mu <- maybeAuth
|
||||
defaultLayout $ do
|
||||
h2id <- newIdent
|
||||
setTitle "~project~ homepage"
|
||||
ident <- newIdent
|
||||
form <- extractBody wform
|
||||
addBody $(hamletFile "homepage")
|
||||
addStyle $(cassiusFile "homepage")
|
||||
addJavascript $(juliusFile "homepage")
|
||||
|
||||
postRootR :: Handler ()
|
||||
postRootR = do
|
||||
(res, _, _) <- runFormPost $ messageFormlet Nothing
|
||||
case res of
|
||||
FormSuccess message -> runDB (insert message) >> return ()
|
||||
_ -> return ()
|
||||
redirect RedirectTemporary RootR
|
||||
|]
|
||||
|
||||
writeFile' "Model.hs" [$codegen|
|
||||
@ -302,8 +371,15 @@ module Model where
|
||||
import Yesod
|
||||
|
||||
mkPersist [$persist|
|
||||
Message
|
||||
content Textarea
|
||||
User
|
||||
ident String
|
||||
password String null update
|
||||
UniqueUser ident
|
||||
Email
|
||||
email String
|
||||
user UserId null update
|
||||
verkey String null update
|
||||
UniqueEmail email
|
||||
|~~]
|
||||
|]
|
||||
|
||||
@ -399,21 +475,17 @@ body
|
||||
|
||||
writeFile' "hamlet/homepage.hamlet" [$codegen|
|
||||
%h1 Hello
|
||||
%p#$ident$ Welcome.
|
||||
%h3 Messages
|
||||
$if null.messages
|
||||
%p No messages.
|
||||
$else
|
||||
%ul
|
||||
$forall messages m
|
||||
%li $messageContent.snd.m$
|
||||
%h3 Add Message
|
||||
%form!method=post!action=@RootR@
|
||||
%table
|
||||
^form^
|
||||
%tr
|
||||
%td!colspan=2
|
||||
%input!type=submit!value="Add Message"
|
||||
%h2#$h2id$ You do not have Javascript enabled.
|
||||
$maybe mu u
|
||||
%p
|
||||
You are logged in as $userIdent.snd.u$. $
|
||||
%a!href=@AuthR.LogoutR@ Logout
|
||||
\.
|
||||
$nothing
|
||||
%p
|
||||
You are not logged in. $
|
||||
%a!href=@AuthR.LoginR@ Login now
|
||||
\.
|
||||
|]
|
||||
|
||||
writeFile' "cassius/homepage.cassius" [$codegen|
|
||||
@ -421,11 +493,13 @@ body
|
||||
font-family: sans-serif
|
||||
h1
|
||||
text-align: center
|
||||
h2#$h2id$
|
||||
color: #990
|
||||
|]
|
||||
|
||||
writeFile' "julius/homepage.julius" [$codegen|
|
||||
window.onload = function(){
|
||||
document.getElementById("%ident%").innerHTML = "<i>Added from JavaScript.</i>";
|
||||
document.getElementById("%h2id%").innerHTML = "<i>Added from JavaScript.</i>";
|
||||
}
|
||||
|]
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user