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

Cleaned up auth module

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

269
Yesod/Helpers/Auth.hs
View File

@ -32,14 +32,9 @@ module Yesod.Helpers.Auth
, EmailCreds (..) , EmailCreds (..)
, AuthType (..) , AuthType (..)
, AuthEmailSettings (..) , AuthEmailSettings (..)
, inMemoryEmailSettings
-- * 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
@ -54,28 +49,31 @@ import Control.Monad
import System.Random import System.Random
import Data.Digest.Pure.MD5 import Data.Digest.Pure.MD5
import Control.Applicative import Control.Applicative
import Control.Concurrent.MVar
import System.IO
import Control.Monad.Attempt import Control.Monad.Attempt
import Data.ByteString.Lazy.UTF8 (fromString) import Data.ByteString.Lazy.UTF8 (fromString)
import Data.Object import Data.Object
import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax
-- | Minimal complete definition: 'defaultDest' and 'defaultLoginRoute'. class (Integral (AuthEmailId master), Yesod master,
class Yesod master => YesodAuth master where Show (AuthId master), Read (AuthId master), Eq (AuthId master)
) => YesodAuth master where
type AuthId master
type AuthEmailId master
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
-- | Default destination on successful login or logout, if no other -- | Default destination on successful login or logout, if no other
-- destination exists. -- destination exists.
defaultDest :: master -> Route master defaultDest :: master -> Route master
-- | Default page to redirect user to for logging in. getAuthId :: Creds master -> [(String, String)]
defaultLoginRoute :: master -> Route master -> GHandler s master (Maybe (AuthId master))
-- | Callback for a successful login.
--
-- The second parameter can contain various information, depending on login
-- mechanism.
onLogin :: Creds -> [(String, String)] -> GHandler Auth master ()
onLogin _ _ = return ()
-- | Generate a random alphanumeric string. -- | Generate a random alphanumeric string.
-- --
@ -85,18 +83,18 @@ class Yesod master => YesodAuth master where
stdgen <- newStdGen stdgen <- newStdGen
return $ fst $ randomString 10 stdgen return $ fst $ randomString 10 stdgen
authIsOpenIdEnabled :: master -> Bool openIdEnabled :: master -> Bool
authIsOpenIdEnabled _ = False openIdEnabled _ = False
authRpxnowApiKey :: master -> Maybe String rpxnowApiKey :: master -> Maybe String
authRpxnowApiKey _ = Nothing rpxnowApiKey _ = Nothing
authEmailSettings :: master -> Maybe (AuthEmailSettings master) emailSettings :: master -> Maybe (AuthEmailSettings master)
authEmailSettings _ = Nothing emailSettings _ = Nothing
-- | client id, secret and requested permissions -- | client id, secret and requested permissions
authFacebook :: master -> Maybe (String, String, [String]) facebookKeys :: master -> Maybe (String, String, [String])
authFacebook _ = Nothing facebookKeys _ = Nothing
data Auth = Auth data Auth = Auth
@ -110,60 +108,57 @@ data AuthType = AuthOpenId | AuthRpxnow | AuthEmail | AuthFacebook
type Email = String type Email = String
type VerKey = String type VerKey = String
type VerUrl = String type VerUrl = String
type EmailId = Integer
type SaltedPass = String type SaltedPass = String
type VerStatus = Bool type VerStatus = Bool
-- | Data stored in a database for each e-mail address. -- | Data stored in a database for each e-mail address.
data EmailCreds = EmailCreds data EmailCreds m = EmailCreds
{ emailCredsId :: EmailId { emailCredsId :: AuthEmailId m
, emailCredsPass :: Maybe SaltedPass , emailCredsAuthId :: Maybe (AuthId m)
, emailCredsStatus :: VerStatus , emailCredsStatus :: VerStatus
, emailCredsVerkey :: Maybe VerKey , emailCredsVerkey :: Maybe VerKey
} }
-- | For a sample set of settings for a trivial in-memory database, see
-- 'inMemoryEmailSettings'.
data AuthEmailSettings m = AuthEmailSettings data AuthEmailSettings m = AuthEmailSettings
{ addUnverified :: Email -> VerKey -> GHandler Auth m EmailId { addUnverified :: Email -> VerKey -> GHandler Auth m (AuthEmailId m)
, sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler Auth m () , sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler Auth m ()
, getVerifyKey :: EmailId -> GHandler Auth m (Maybe VerKey) , getVerifyKey :: AuthEmailId m -> GHandler Auth m (Maybe VerKey)
, setVerifyKey :: EmailId -> VerKey -> GHandler Auth m () , setVerifyKey :: AuthEmailId m -> VerKey -> GHandler Auth m ()
, verifyAccount :: EmailId -> GHandler Auth m () , verifyAccount :: AuthEmailId m -> GHandler Auth m (Maybe (AuthId m))
, setPassword :: EmailId -> String -> GHandler Auth m () , getPassword :: AuthId m -> GHandler Auth m (Maybe SaltedPass)
, getEmailCreds :: Email -> GHandler Auth m (Maybe EmailCreds) , setPassword :: AuthId m -> SaltedPass -> GHandler Auth m ()
, getEmail :: EmailId -> GHandler Auth m (Maybe Email) , getEmailCreds :: Email -> GHandler Auth m (Maybe (EmailCreds m))
, getEmail :: AuthEmailId m -> GHandler Auth m (Maybe Email)
} }
-- | User credentials -- | User credentials
data Creds = Creds data Creds m = Creds
{ credsIdent :: String -- ^ Identifier. Exact meaning depends on 'credsAuthType'. { credsIdent :: String -- ^ Identifier. Exact meaning depends on 'credsAuthType'.
, credsAuthType :: AuthType -- ^ How the user was authenticated , credsAuthType :: AuthType -- ^ How the user was authenticated
, credsEmail :: Maybe String -- ^ Verified e-mail address. , credsEmail :: Maybe String -- ^ Verified e-mail address.
, credsDisplayName :: Maybe String -- ^ Display name. , credsDisplayName :: Maybe String -- ^ Display name.
, credsId :: Maybe Integer -- ^ Numeric ID, if used. , credsId :: Maybe (AuthId m) -- ^ Numeric ID, if used.
, credsFacebookToken :: Maybe Facebook.AccessToken , credsFacebookToken :: Maybe Facebook.AccessToken
} }
deriving (Show, Read, Eq)
credsKey :: String credsKey :: String
credsKey = "_CREDS" credsKey = "_ID"
setCreds :: YesodAuth master setCreds :: YesodAuth master
=> Creds -> [(String, String)] -> GHandler Auth master () => Creds master -> [(String, String)] -> GHandler Auth master ()
setCreds creds extra = do setCreds creds extra = do
setSession credsKey $ show creds maid <- getAuthId creds extra
onLogin creds extra case maid of
Nothing -> return ()
Just aid -> showAuthId aid >>= setSession credsKey
-- | Retrieves user credentials, if user is authenticated. -- | Retrieves user credentials, if user is authenticated.
maybeCreds :: RequestReader r => r (Maybe Creds) maybeCreds :: YesodAuth m => GHandler s m (Maybe (AuthId m))
maybeCreds = do maybeCreds = do
mstring <- lookupSession credsKey ms <- lookupSession credsKey
return $ mstring >>= readMay case ms of
where Nothing -> return Nothing
readMay x = case reads x of Just s -> readAuthId s
(y, _):_ -> Just y
_ -> Nothing
mkYesodSub "Auth" mkYesodSub "Auth"
[ ClassP ''YesodAuth [VarT $ mkName "master"] [ ClassP ''YesodAuth [VarT $ mkName "master"]
@ -188,7 +183,7 @@ mkYesodSub "Auth"
testOpenId :: YesodAuth master => GHandler Auth master () testOpenId :: YesodAuth master => GHandler Auth master ()
testOpenId = do testOpenId = do
a <- getYesod a <- getYesod
unless (authIsOpenIdEnabled a) notFound unless (openIdEnabled a) notFound
getOpenIdR :: YesodAuth master => GHandler Auth master RepHtml getOpenIdR :: YesodAuth master => GHandler Auth master RepHtml
getOpenIdR = do getOpenIdR = do
@ -242,7 +237,7 @@ handleRpxnowR :: YesodAuth master => GHandler Auth master ()
handleRpxnowR = do handleRpxnowR = do
ay <- getYesod ay <- getYesod
auth <- getYesod auth <- getYesod
apiKey <- case authRpxnowApiKey auth of apiKey <- case rpxnowApiKey auth of
Just x -> return x Just x -> return x
Nothing -> notFound Nothing -> notFound
token1 <- lookupGetParam "token" token1 <- lookupGetParam "token"
@ -275,7 +270,7 @@ getDisplayName extra =
where where
choices = ["verifiedEmail", "email", "displayName", "preferredUsername"] choices = ["verifiedEmail", "email", "displayName", "preferredUsername"]
getCheckR :: Yesod master => GHandler Auth master RepHtmlJson getCheckR :: YesodAuth master => GHandler Auth master RepHtmlJson
getCheckR = do getCheckR = do
creds <- maybeCreds creds <- maybeCreds
defaultLayoutJson (do defaultLayoutJson (do
@ -285,15 +280,13 @@ getCheckR = do
html creds = [$hamlet| html creds = [$hamlet|
%h1 Authentication Status %h1 Authentication Status
$if isNothing.creds $if isNothing.creds
%p Not logged in %p Not logged in.
$maybe creds c $maybe creds _
%p Logged in as $credsIdent.c$ %p Logged in.
|] |]
json creds = json creds =
jsonMap jsonMap
[ ("ident", jsonScalar $ maybe "" credsIdent creds) [ ("logged_in", jsonScalar $ maybe "false" (const "true") creds)
, ("displayName", jsonScalar $ fromMaybe ""
$ creds >>= credsDisplayName)
] ]
getLogoutR :: YesodAuth master => GHandler Auth master () getLogoutR :: YesodAuth master => GHandler Auth master ()
@ -303,20 +296,22 @@ getLogoutR = do
redirectUltDest RedirectTemporary $ defaultDest y redirectUltDest RedirectTemporary $ defaultDest y
-- | Retrieve user credentials. If user is not logged in, redirects to the -- | Retrieve user credentials. If user is not logged in, redirects to the
-- 'defaultLoginRoute'. Sets ultimate destination to current route, so user -- 'authRoute'. Sets ultimate destination to current route, so user
-- should be sent back here after authenticating. -- should be sent back here after authenticating.
requireCreds :: YesodAuth master => GHandler sub master Creds requireCreds :: YesodAuth m => GHandler sub m (AuthId m)
requireCreds = requireCreds =
maybeCreds >>= maybe redirectLogin return maybeCreds >>= maybe redirectLogin return
where where
redirectLogin = do redirectLogin = do
y <- getYesod y <- getYesod
setUltDest' setUltDest'
redirect RedirectTemporary $ defaultLoginRoute y case authRoute y of
Just z -> redirect RedirectTemporary z
Nothing -> permissionDenied "Please configure authRoute"
getAuthEmailSettings :: YesodAuth master getAuthEmailSettings :: YesodAuth master
=> GHandler Auth master (AuthEmailSettings master) => GHandler Auth master (AuthEmailSettings master)
getAuthEmailSettings = getYesod >>= maybe notFound return . authEmailSettings getAuthEmailSettings = getYesod >>= maybe notFound return . emailSettings
getEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml getEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml
getEmailRegisterR = do getEmailRegisterR = do
@ -350,7 +345,7 @@ postEmailRegisterR = do
return (lid, key) return (lid, key)
render <- getUrlRender render <- getUrlRender
tm <- getRouteToMaster tm <- getRouteToMaster
let verUrl = render $ tm $ EmailVerifyR lid verKey let verUrl = render $ tm $ EmailVerifyR (fromIntegral lid) verKey
sendVerifyEmail ae email verKey verUrl sendVerifyEmail ae email verKey verUrl
defaultLayout $ setTitle "Confirmation e-mail sent" >> addBody [$hamlet| defaultLayout $ setTitle "Confirmation e-mail sent" >> addBody [$hamlet|
%p A confirmation e-mail has been sent to $email$. %p A confirmation e-mail has been sent to $email$.
@ -358,20 +353,25 @@ postEmailRegisterR = do
getEmailVerifyR :: YesodAuth master getEmailVerifyR :: YesodAuth master
=> Integer -> String -> GHandler Auth master RepHtml => Integer -> String -> GHandler Auth master RepHtml
getEmailVerifyR lid key = do getEmailVerifyR lid' key = do
let lid = fromInteger lid'
ae <- getAuthEmailSettings ae <- getAuthEmailSettings
realKey <- getVerifyKey ae lid realKey <- getVerifyKey ae lid
memail <- getEmail ae lid memail <- getEmail ae lid
case (realKey == Just key, memail) of case (realKey == Just key, memail) of
(True, Just email) -> do (True, Just email) -> do
verifyAccount ae lid muid <- verifyAccount ae lid
setCreds (Creds email AuthEmail (Just email) Nothing (Just lid) case muid of
Nothing) [] Nothing -> return ()
toMaster <- getRouteToMaster Just uid -> do
redirect RedirectTemporary $ toMaster EmailPasswordR setCreds (Creds email AuthEmail (Just email) Nothing (Just uid)
_ -> defaultLayout $ do Nothing) []
setTitle "Invalid verification key" toMaster <- getRouteToMaster
addBody [$hamlet| redirect RedirectTemporary $ toMaster EmailPasswordR
_ -> return ()
defaultLayout $ do
setTitle "Invalid verification key"
addBody [$hamlet|
%p I'm sorry, but that was an invalid verification key. %p I'm sorry, but that was an invalid verification key.
|] |]
@ -411,14 +411,20 @@ postEmailLoginR = do
<*> stringInput "password" <*> stringInput "password"
y <- getYesod y <- getYesod
mecreds <- getEmailCreds ae email mecreds <- getEmailCreds ae email
let mlid = maid <-
case mecreds of case (mecreds >>= emailCredsAuthId, fmap emailCredsStatus mecreds) of
Just (EmailCreds lid (Just realpass) True _) -> (Just aid, Just True) -> do
if isValidPass pass realpass then Just lid else Nothing mrealpass <- getPassword ae aid
_ -> Nothing case mrealpass of
case mlid of Nothing -> return Nothing
Just lid -> do Just realpass -> return $
setCreds (Creds email AuthEmail (Just email) Nothing (Just lid) if isValidPass pass realpass
then Just aid
else Nothing
_ -> return Nothing
case maid of
Just aid -> do
setCreds (Creds email AuthEmail (Just email) Nothing (Just aid)
Nothing) [] Nothing) []
redirectUltDest RedirectTemporary $ defaultDest y redirectUltDest RedirectTemporary $ defaultDest y
Nothing -> do Nothing -> do
@ -430,18 +436,15 @@ getEmailPasswordR :: YesodAuth master => GHandler Auth master RepHtml
getEmailPasswordR = do getEmailPasswordR = do
_ae <- getAuthEmailSettings _ae <- getAuthEmailSettings
toMaster <- getRouteToMaster toMaster <- getRouteToMaster
mcreds <- maybeCreds maid <- maybeCreds
case mcreds of case maid of
Just (Creds _ AuthEmail _ _ (Just _) _) -> return () Just _ -> return ()
_ -> do Nothing -> do
setMessage $ string "You must be logged in to set a password" setMessage $ string "You must be logged in to set a password"
redirect RedirectTemporary $ toMaster EmailLoginR redirect RedirectTemporary $ toMaster EmailLoginR
msg <- getMessage
defaultLayout $ do defaultLayout $ do
setTitle "Set password" setTitle "Set password"
addBody [$hamlet| addBody [$hamlet|
$maybe msg ms
%p.message $ms$
%h3 Set a new password %h3 Set a new password
%form!method=post!action=@toMaster.EmailPasswordR@ %form!method=post!action=@toMaster.EmailPasswordR@
%table %table
@ -468,16 +471,17 @@ postEmailPasswordR = do
when (new /= confirm) $ do when (new /= confirm) $ do
setMessage $ string "Passwords did not match, please try again" setMessage $ string "Passwords did not match, please try again"
redirect RedirectTemporary $ toMaster EmailPasswordR redirect RedirectTemporary $ toMaster EmailPasswordR
mcreds <- maybeCreds maid <- maybeCreds
lid <- case mcreds of aid <- case maid of
Just (Creds _ AuthEmail _ _ (Just lid) _) -> return lid Nothing -> do
_ -> do
setMessage $ string "You must be logged in to set a password" setMessage $ string "You must be logged in to set a password"
redirect RedirectTemporary $ toMaster EmailLoginR redirect RedirectTemporary $ toMaster EmailLoginR
Just aid -> return aid
salted <- liftIO $ saltPass new salted <- liftIO $ saltPass new
setPassword ae lid salted setPassword ae aid salted
setMessage $ string "Password updated" setMessage $ string "Password updated"
redirect RedirectTemporary $ toMaster EmailLoginR y <- getYesod
redirect RedirectTemporary $ defaultDest y
saltLength :: Int saltLength :: Int
saltLength = 5 saltLength = 5
@ -498,47 +502,10 @@ saltPass pass = do
saltPass' :: String -> String -> String saltPass' :: String -> String -> String
saltPass' salt pass = salt ++ show (md5 $ fromString $ salt ++ pass) saltPass' salt pass = salt ++ show (md5 $ fromString $ salt ++ pass)
-- | A simplistic set of email settings, useful only for testing purposes. In
-- particular, it doesn't actually send emails, but instead prints verification
-- URLs to stderr.
inMemoryEmailSettings :: IO (AuthEmailSettings a)
inMemoryEmailSettings = do
mm <- newMVar []
return AuthEmailSettings
{ addUnverified = \email verkey -> liftIO $ modifyMVar mm $ \m -> do
let helper (_, EmailCreds x _ _ _) = x
let newId = 1 + maximum (0 : map helper m)
let ec = EmailCreds newId Nothing False $ Just verkey
return ((email, ec) : m, newId)
, sendVerifyEmail = \_email _verkey verurl -> liftIO $
hPutStrLn stderr $ "Please go to: " ++ verurl
, getVerifyKey = \eid -> liftIO $ withMVar mm $ \m -> return $
join $ lookup eid $ map (\(_, EmailCreds eid' _ _ vk) -> (eid', vk)) m
, setVerifyKey = \eid key -> liftIO $ modifyMVar_ mm $ \m -> return $
map (setHelper eid key) m
, verifyAccount = \eid -> liftIO $ modifyMVar_ mm $ return . map (vago eid)
, setPassword = \eid pass -> liftIO $ modifyMVar_ mm $ return . map (spgo eid pass)
, getEmailCreds = \email -> liftIO $ withMVar mm $ return . lookup email
, getEmail = \eid -> liftIO $ withMVar mm $ \m -> return $
case filter (\(_, EmailCreds eid' _ _ _) -> eid == eid') m of
((email, _):_) -> Just email
_ -> Nothing
}
where
setHelper eid key pair@(k, EmailCreds eid' b c _)
| eid == eid' = (k, EmailCreds eid b c $ Just key)
| otherwise = pair
vago eid (email, EmailCreds eid' pass status key)
| eid == eid' = (email, EmailCreds eid pass True key)
| otherwise = (email, EmailCreds eid' pass status key)
spgo eid pass (email, EmailCreds eid' pass' status key)
| eid == eid' = (email, EmailCreds eid (Just pass) status key)
| otherwise = (email, EmailCreds eid' pass' status key)
getFacebookR :: YesodAuth master => GHandler Auth master () getFacebookR :: YesodAuth master => GHandler Auth master ()
getFacebookR = do getFacebookR = do
y <- getYesod y <- getYesod
a <- authFacebook <$> getYesod a <- facebookKeys <$> getYesod
case a of case a of
Nothing -> notFound Nothing -> notFound
Just (cid, secret, _) -> do Just (cid, secret, _) -> do
@ -561,7 +528,7 @@ getFacebookR = do
getStartFacebookR :: YesodAuth master => GHandler Auth master () getStartFacebookR :: YesodAuth master => GHandler Auth master ()
getStartFacebookR = do getStartFacebookR = do
y <- getYesod y <- getYesod
case authFacebook y of case facebookKeys y of
Nothing -> notFound Nothing -> notFound
Just (cid, secret, perms) -> do Just (cid, secret, perms) -> do
render <- getUrlRender render <- getUrlRender
@ -569,33 +536,3 @@ 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)