diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs
index 9edcbd19..d930f521 100644
--- a/Yesod/Helpers/Auth.hs
+++ b/Yesod/Helpers/Auth.hs
@@ -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
diff --git a/scaffold.hs b/scaffold.hs
index 2a09b8d5..71148489 100644
--- a/scaffold.hs
+++ b/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 = "Added from JavaScript.";
+ document.getElementById("%h2id%").innerHTML = "Added from JavaScript.";
}
|]