haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Beginning of major refactoring of Auth helper

Browse Source
This commit is contained in:
Michael Snoyman 2010-08-26 00:14:42 +03:00
parent 1c28d0f9d0
commit 86653cd8f5
2 changed files with 90 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

128
Yesod/Helpers/Auth.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
@ -23,6 +24,7 @@
module Yesod.Helpers.Auth module Yesod.Helpers.Auth
( -- * Subsite ( -- * Subsite
Auth (..) Auth (..)
, getAuth
, AuthRoute (..) , AuthRoute (..)
-- * Settings -- * Settings
, YesodAuth (..) , YesodAuth (..)
@ -34,6 +36,10 @@ module Yesod.Helpers.Auth
-- * Functions -- * Functions
, maybeCreds , maybeCreds
, requireCreds , requireCreds
-- * AuthId
, YesodAuthId (..)
, maybeAuthId
, requireAuthId
) where ) where
import qualified Web.Authenticate.Rpxnow as Rpxnow import qualified Web.Authenticate.Rpxnow as Rpxnow
@ -68,7 +74,7 @@ class Yesod master => YesodAuth master where
-- --
-- The second parameter can contain various information, depending on login -- The second parameter can contain various information, depending on login
-- mechanism. -- mechanism.
onLogin :: Creds -> [(String, String)] -> GHandler (Auth master) master () onLogin :: Creds -> [(String, String)] -> GHandler Auth master ()
onLogin _ _ = return () onLogin _ _ = return ()
-- | Generate a random alphanumeric string. -- | Generate a random alphanumeric string.
@ -79,16 +85,23 @@ class Yesod master => YesodAuth master where
stdgen <- newStdGen stdgen <- newStdGen
return $ fst $ randomString 10 stdgen return $ fst $ randomString 10 stdgen
-- | Each authentication subsystem (OpenId, Rpxnow, Email, Facebook) has its authIsOpenIdEnabled :: master -> Bool
-- own settings. If those settings are not present, then relevant handlers will authIsOpenIdEnabled _ = False
-- simply return a 404.
data Auth m = Auth authRpxnowApiKey :: master -> Maybe String
{ authIsOpenIdEnabled :: Bool authRpxnowApiKey _ = Nothing
, authRpxnowApiKey :: Maybe String
, authEmailSettings :: Maybe (AuthEmailSettings m) authEmailSettings :: master -> Maybe (AuthEmailSettings master)
authEmailSettings _ = Nothing
-- | client id, secret and requested permissions -- | client id, secret and requested permissions
, authFacebook :: Maybe (String, String, [String]) authFacebook :: master -> Maybe (String, String, [String])
} authFacebook _ = Nothing
data Auth = Auth
getAuth :: a -> Auth
getAuth = const Auth
-- | Which subsystem authenticated the user. -- | Which subsystem authenticated the user.
data AuthType = AuthOpenId | AuthRpxnow | AuthEmail | AuthFacebook data AuthType = AuthOpenId | AuthRpxnow | AuthEmail | AuthFacebook
@ -112,14 +125,14 @@ data EmailCreds = EmailCreds
-- | For a sample set of settings for a trivial in-memory database, see -- | For a sample set of settings for a trivial in-memory database, see
-- 'inMemoryEmailSettings'. -- 'inMemoryEmailSettings'.
data AuthEmailSettings m = AuthEmailSettings data AuthEmailSettings m = AuthEmailSettings
{ addUnverified :: Email -> VerKey -> GHandler (Auth m) m EmailId { addUnverified :: Email -> VerKey -> GHandler Auth m EmailId
, sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler (Auth m) m () , sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler Auth m ()
, getVerifyKey :: EmailId -> GHandler (Auth m) m (Maybe VerKey) , getVerifyKey :: EmailId -> GHandler Auth m (Maybe VerKey)
, setVerifyKey :: EmailId -> VerKey -> GHandler (Auth m) m () , setVerifyKey :: EmailId -> VerKey -> GHandler Auth m ()
, verifyAccount :: EmailId -> GHandler (Auth m) m () , verifyAccount :: EmailId -> GHandler Auth m ()
, setPassword :: EmailId -> String -> GHandler (Auth m) m () , setPassword :: EmailId -> String -> GHandler Auth m ()
, getEmailCreds :: Email -> GHandler (Auth m) m (Maybe EmailCreds) , getEmailCreds :: Email -> GHandler Auth m (Maybe EmailCreds)
, getEmail :: EmailId -> GHandler (Auth m) m (Maybe Email) , getEmail :: EmailId -> GHandler Auth m (Maybe Email)
} }
-- | User credentials -- | User credentials
@ -137,7 +150,7 @@ credsKey :: String
credsKey = "_CREDS" credsKey = "_CREDS"
setCreds :: YesodAuth master setCreds :: YesodAuth master
=> Creds -> [(String, String)] -> GHandler (Auth master) master () => Creds -> [(String, String)] -> GHandler Auth master ()
setCreds creds extra = do setCreds creds extra = do
setSession credsKey $ show creds setSession credsKey $ show creds
onLogin creds extra onLogin creds extra
@ -152,7 +165,7 @@ maybeCreds = do
(y, _):_ -> Just y (y, _):_ -> Just y
_ -> Nothing _ -> Nothing
mkYesodSub "Auth master" mkYesodSub "Auth"
[ ClassP ''YesodAuth [VarT $ mkName "master"] [ ClassP ''YesodAuth [VarT $ mkName "master"]
] ]
[$parseRoutes| [$parseRoutes|
@ -172,12 +185,12 @@ mkYesodSub "Auth master"
/set-password EmailPasswordR GET POST /set-password EmailPasswordR GET POST
|] |]
testOpenId :: GHandler (Auth master) master () testOpenId :: YesodAuth master => GHandler Auth master ()
testOpenId = do testOpenId = do
a <- getYesodSub a <- getYesod
unless (authIsOpenIdEnabled a) notFound unless (authIsOpenIdEnabled a) notFound
getOpenIdR :: Yesod master => GHandler (Auth master) master RepHtml getOpenIdR :: YesodAuth master => GHandler Auth master RepHtml
getOpenIdR = do getOpenIdR = do
testOpenId testOpenId
lookupGetParam "dest" >>= maybe (return ()) setUltDestString lookupGetParam "dest" >>= maybe (return ()) setUltDestString
@ -194,7 +207,7 @@ $maybe message msg
%input!type=submit!value=Login %input!type=submit!value=Login
|] |]
getOpenIdForwardR :: GHandler (Auth master) master () getOpenIdForwardR :: YesodAuth master => GHandler Auth master ()
getOpenIdForwardR = do getOpenIdForwardR = do
testOpenId testOpenId
oid <- runFormGet' $ stringInput "openid" oid <- runFormGet' $ stringInput "openid"
@ -209,7 +222,7 @@ getOpenIdForwardR = do
(redirectString RedirectTemporary) (redirectString RedirectTemporary)
res res
getOpenIdCompleteR :: YesodAuth master => GHandler (Auth master) master () getOpenIdCompleteR :: YesodAuth master => GHandler Auth master ()
getOpenIdCompleteR = do getOpenIdCompleteR = do
testOpenId testOpenId
rr <- getRequest rr <- getRequest
@ -225,10 +238,10 @@ getOpenIdCompleteR = do
redirectUltDest RedirectTemporary $ defaultDest y redirectUltDest RedirectTemporary $ defaultDest y
attempt onFailure onSuccess res attempt onFailure onSuccess res
handleRpxnowR :: YesodAuth master => GHandler (Auth master) master () handleRpxnowR :: YesodAuth master => GHandler Auth master ()
handleRpxnowR = do handleRpxnowR = do
ay <- getYesod ay <- getYesod
auth <- getYesodSub auth <- getYesod
apiKey <- case authRpxnowApiKey auth of apiKey <- case authRpxnowApiKey auth of
Just x -> return x Just x -> return x
Nothing -> notFound Nothing -> notFound
@ -262,7 +275,7 @@ getDisplayName extra =
where where
choices = ["verifiedEmail", "email", "displayName", "preferredUsername"] choices = ["verifiedEmail", "email", "displayName", "preferredUsername"]
getCheckR :: Yesod master => GHandler (Auth master) master RepHtmlJson getCheckR :: Yesod master => GHandler Auth master RepHtmlJson
getCheckR = do getCheckR = do
creds <- maybeCreds creds <- maybeCreds
defaultLayoutJson (do defaultLayoutJson (do
@ -283,7 +296,7 @@ $maybe creds c
$ creds >>= credsDisplayName) $ creds >>= credsDisplayName)
] ]
getLogoutR :: YesodAuth master => GHandler (Auth master) master () getLogoutR :: YesodAuth master => GHandler Auth master ()
getLogoutR = do getLogoutR = do
y <- getYesod y <- getYesod
deleteSession credsKey deleteSession credsKey
@ -301,10 +314,11 @@ requireCreds =
setUltDest' setUltDest'
redirect RedirectTemporary $ defaultLoginRoute y redirect RedirectTemporary $ defaultLoginRoute y
getAuthEmailSettings :: GHandler (Auth master) master (AuthEmailSettings master) getAuthEmailSettings :: YesodAuth master
getAuthEmailSettings = getYesodSub >>= maybe notFound return . authEmailSettings => GHandler Auth master (AuthEmailSettings master)
getAuthEmailSettings = getYesod >>= maybe notFound return . authEmailSettings
getEmailRegisterR :: Yesod master => GHandler (Auth master) master RepHtml getEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml
getEmailRegisterR = do getEmailRegisterR = do
_ae <- getAuthEmailSettings _ae <- getAuthEmailSettings
toMaster <- getRouteToMaster toMaster <- getRouteToMaster
@ -316,7 +330,7 @@ getEmailRegisterR = do
%input!type=submit!value=Register %input!type=submit!value=Register
|] |]
postEmailRegisterR :: YesodAuth master => GHandler (Auth master) master RepHtml postEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml
postEmailRegisterR = do postEmailRegisterR = do
ae <- getAuthEmailSettings ae <- getAuthEmailSettings
email <- runFormPost' $ emailInput "email" email <- runFormPost' $ emailInput "email"
@ -343,7 +357,7 @@ postEmailRegisterR = do
|] |]
getEmailVerifyR :: YesodAuth master getEmailVerifyR :: YesodAuth master
=> Integer -> String -> GHandler (Auth master) master RepHtml => Integer -> String -> GHandler Auth master RepHtml
getEmailVerifyR lid key = do getEmailVerifyR lid key = do
ae <- getAuthEmailSettings ae <- getAuthEmailSettings
realKey <- getVerifyKey ae lid realKey <- getVerifyKey ae lid
@ -361,7 +375,7 @@ getEmailVerifyR lid key = do
%p I'm sorry, but that was an invalid verification key. %p I'm sorry, but that was an invalid verification key.
|] |]
getEmailLoginR :: Yesod master => GHandler (Auth master) master RepHtml getEmailLoginR :: YesodAuth master => GHandler Auth master RepHtml
getEmailLoginR = do getEmailLoginR = do
_ae <- getAuthEmailSettings _ae <- getAuthEmailSettings
toMaster <- getRouteToMaster toMaster <- getRouteToMaster
@ -389,7 +403,7 @@ $maybe msg ms
%input!type=submit!value=Login %input!type=submit!value=Login
|] |]
postEmailLoginR :: YesodAuth master => GHandler (Auth master) master () postEmailLoginR :: YesodAuth master => GHandler Auth master ()
postEmailLoginR = do postEmailLoginR = do
ae <- getAuthEmailSettings ae <- getAuthEmailSettings
(email, pass) <- runFormPost' $ (,) (email, pass) <- runFormPost' $ (,)
@ -412,7 +426,7 @@ postEmailLoginR = do
toMaster <- getRouteToMaster toMaster <- getRouteToMaster
redirect RedirectTemporary $ toMaster EmailLoginR redirect RedirectTemporary $ toMaster EmailLoginR
getEmailPasswordR :: Yesod master => GHandler (Auth master) master RepHtml getEmailPasswordR :: YesodAuth master => GHandler Auth master RepHtml
getEmailPasswordR = do getEmailPasswordR = do
_ae <- getAuthEmailSettings _ae <- getAuthEmailSettings
toMaster <- getRouteToMaster toMaster <- getRouteToMaster
@ -444,7 +458,7 @@ $maybe msg ms
%input!type=submit!value=Submit %input!type=submit!value=Submit
|] |]
postEmailPasswordR :: YesodAuth master => GHandler (Auth master) master () postEmailPasswordR :: YesodAuth master => GHandler Auth master ()
postEmailPasswordR = do postEmailPasswordR = do
ae <- getAuthEmailSettings ae <- getAuthEmailSettings
(new, confirm) <- runFormPost' $ (,) (new, confirm) <- runFormPost' $ (,)
@ -521,10 +535,10 @@ inMemoryEmailSettings = do
| eid == eid' = (email, EmailCreds eid (Just pass) status key) | eid == eid' = (email, EmailCreds eid (Just pass) status key)
| otherwise = (email, EmailCreds eid' pass' status key) | otherwise = (email, EmailCreds eid' pass' status key)
getFacebookR :: YesodAuth master => GHandler (Auth master) master () getFacebookR :: YesodAuth master => GHandler Auth master ()
getFacebookR = do getFacebookR = do
y <- getYesod y <- getYesod
a <- authFacebook <$> getYesodSub a <- authFacebook <$> getYesod
case a of case a of
Nothing -> notFound Nothing -> notFound
Just (cid, secret, _) -> do Just (cid, secret, _) -> do
@ -544,9 +558,9 @@ getFacebookR = do
setCreds c [] setCreds c []
redirectUltDest RedirectTemporary $ defaultDest y redirectUltDest RedirectTemporary $ defaultDest y
getStartFacebookR :: GHandler (Auth master) master () getStartFacebookR :: YesodAuth master => GHandler Auth master ()
getStartFacebookR = do getStartFacebookR = do
y <- getYesodSub y <- getYesod
case authFacebook y of case authFacebook y of
Nothing -> notFound Nothing -> notFound
Just (cid, secret, perms) -> do Just (cid, secret, perms) -> do
@ -555,3 +569,33 @@ getStartFacebookR = do
let fb = Facebook.Facebook cid secret $ render $ tm FacebookR let fb = Facebook.Facebook cid secret $ render $ tm FacebookR
let fburl = Facebook.getForwardUrl fb perms let fburl = Facebook.getForwardUrl fb perms
redirectString RedirectTemporary fburl redirectString RedirectTemporary fburl
class ( YesodAuth m
, YesodPersist m
, PersistEntity (AuthEntity m)
) => YesodAuthId m where
type AuthEntity m
newAuthEntity :: Creds -> (YesodDB m) (GHandler s m) (AuthEntity m)
getAuthEntity :: Creds
-> (YesodDB m) (GHandler s m)
(Maybe (Key (AuthEntity m), AuthEntity m))
maybeAuthId :: (YesodAuthId m, PersistBackend (YesodDB m (GHandler s m)))
=> GHandler s m (Maybe (Key (AuthEntity m), AuthEntity m))
maybeAuthId = maybeCreds >>= maybe (return Nothing) (fmap Just . authIdHelper)
requireAuthId :: (YesodAuthId m, PersistBackend (YesodDB m (GHandler s m)))
=> GHandler s m (Key (AuthEntity m), AuthEntity m)
requireAuthId = requireCreds >>= authIdHelper
authIdHelper :: (YesodAuthId m, PersistBackend (YesodDB m (GHandler s m)))
=> Creds
-> GHandler s m (Key (AuthEntity m), AuthEntity m)
authIdHelper creds = runDB $ do
x <- getAuthEntity creds
case x of
Just y -> return y
Nothing -> do
user <- newAuthEntity creds
uid <- insert user
return (uid, user)

5
scaffold.hs
View File

@ -80,7 +80,7 @@ import Controller
import Network.Wai.Handler.SimpleServer (run) import Network.Wai.Handler.SimpleServer (run)
main :: IO () main :: IO ()
main = with~sitearg~ $ run 3000 main = putStrLn "Loaded" >> with~sitearg~ (run 3000)
|] |]
writeFile' "fastcgi.hs" [$codegen| writeFile' "fastcgi.hs" [$codegen|
@ -205,6 +205,7 @@ mkYesodData "~sitearg~" [$parseRoutes|
instance Yesod ~sitearg~ where instance Yesod ~sitearg~ where
approot _ = Settings.approot approot _ = Settings.approot
defaultLayout widget = do defaultLayout widget = do
mmsg <- getMessage
pc <- widgetToPageContent $ do pc <- widgetToPageContent $ do
widget widget
addStyle $(Settings.cassiusFile "default-layout") addStyle $(Settings.cassiusFile "default-layout")
@ -391,6 +392,8 @@ body
%title $pageTitle.pc$ %title $pageTitle.pc$
^pageHead.pc^ ^pageHead.pc^
%body %body
$maybe mmsg msg
#message $msg$
^pageBody.pc^ ^pageBody.pc^
|] |]