Cleaned up auth module
This commit is contained in:
Michael Snoyman
parent
86653cd8f5
commit
a03cc7cff8
@ -32,14 +32,9 @@ module Yesod.Helpers.Auth
|
||||
, EmailCreds (..)
|
||||
, AuthType (..)
|
||||
, AuthEmailSettings (..)
|
||||
, inMemoryEmailSettings
|
||||
-- * Functions
|
||||
, maybeCreds
|
||||
, requireCreds
|
||||
-- * AuthId
|
||||
, YesodAuthId (..)
|
||||
, maybeAuthId
|
||||
, requireAuthId
|
||||
) where
|
||||
|
||||
import qualified Web.Authenticate.Rpxnow as Rpxnow
|
||||
@ -54,28 +49,31 @@ import Control.Monad
|
||||
import System.Random
|
||||
import Data.Digest.Pure.MD5
|
||||
import Control.Applicative
|
||||
import Control.Concurrent.MVar
|
||||
import System.IO
|
||||
import Control.Monad.Attempt
|
||||
import Data.ByteString.Lazy.UTF8 (fromString)
|
||||
import Data.Object
|
||||
import Language.Haskell.TH.Syntax
|
||||
|
||||
-- | Minimal complete definition: 'defaultDest' and 'defaultLoginRoute'.
|
||||
class Yesod master => YesodAuth master where
|
||||
class (Integral (AuthEmailId master), Yesod master,
|
||||
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
|
||||
-- destination exists.
|
||||
defaultDest :: master -> Route master
|
||||
|
||||
-- | Default page to redirect user to for logging in.
|
||||
defaultLoginRoute :: master -> Route 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 ()
|
||||
getAuthId :: Creds master -> [(String, String)]
|
||||
-> GHandler s master (Maybe (AuthId master))
|
||||
|
||||
-- | Generate a random alphanumeric string.
|
||||
--
|
||||
@ -85,18 +83,18 @@ class Yesod master => YesodAuth master where
|
||||
stdgen <- newStdGen
|
||||
return $ fst $ randomString 10 stdgen
|
||||
|
||||
authIsOpenIdEnabled :: master -> Bool
|
||||
authIsOpenIdEnabled _ = False
|
||||
openIdEnabled :: master -> Bool
|
||||
openIdEnabled _ = False
|
||||
|
||||
authRpxnowApiKey :: master -> Maybe String
|
||||
authRpxnowApiKey _ = Nothing
|
||||
rpxnowApiKey :: master -> Maybe String
|
||||
rpxnowApiKey _ = Nothing
|
||||
|
||||
authEmailSettings :: master -> Maybe (AuthEmailSettings master)
|
||||
authEmailSettings _ = Nothing
|
||||
emailSettings :: master -> Maybe (AuthEmailSettings master)
|
||||
emailSettings _ = Nothing
|
||||
|
||||
-- | client id, secret and requested permissions
|
||||
authFacebook :: master -> Maybe (String, String, [String])
|
||||
authFacebook _ = Nothing
|
||||
facebookKeys :: master -> Maybe (String, String, [String])
|
||||
facebookKeys _ = Nothing
|
||||
|
||||
data Auth = Auth
|
||||
|
||||
@ -110,60 +108,57 @@ data AuthType = AuthOpenId | AuthRpxnow | AuthEmail | AuthFacebook
|
||||
type Email = String
|
||||
type VerKey = String
|
||||
type VerUrl = String
|
||||
type EmailId = Integer
|
||||
type SaltedPass = String
|
||||
type VerStatus = Bool
|
||||
|
||||
-- | Data stored in a database for each e-mail address.
|
||||
data EmailCreds = EmailCreds
|
||||
{ emailCredsId :: EmailId
|
||||
, emailCredsPass :: Maybe SaltedPass
|
||||
data EmailCreds m = EmailCreds
|
||||
{ emailCredsId :: AuthEmailId m
|
||||
, emailCredsAuthId :: Maybe (AuthId m)
|
||||
, emailCredsStatus :: VerStatus
|
||||
, emailCredsVerkey :: Maybe VerKey
|
||||
}
|
||||
|
||||
-- | For a sample set of settings for a trivial in-memory database, see
|
||||
-- 'inMemoryEmailSettings'.
|
||||
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 ()
|
||||
, getVerifyKey :: EmailId -> GHandler Auth m (Maybe VerKey)
|
||||
, setVerifyKey :: EmailId -> VerKey -> GHandler Auth m ()
|
||||
, verifyAccount :: EmailId -> GHandler Auth m ()
|
||||
, setPassword :: EmailId -> String -> GHandler Auth m ()
|
||||
, getEmailCreds :: Email -> GHandler Auth m (Maybe EmailCreds)
|
||||
, getEmail :: EmailId -> GHandler Auth m (Maybe Email)
|
||||
, 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)
|
||||
}
|
||||
|
||||
-- | User credentials
|
||||
data Creds = Creds
|
||||
data Creds m = Creds
|
||||
{ credsIdent :: String -- ^ Identifier. Exact meaning depends on 'credsAuthType'.
|
||||
, credsAuthType :: AuthType -- ^ How the user was authenticated
|
||||
, credsEmail :: Maybe String -- ^ Verified e-mail address.
|
||||
, credsDisplayName :: Maybe String -- ^ Display name.
|
||||
, credsId :: Maybe Integer -- ^ Numeric ID, if used.
|
||||
, credsId :: Maybe (AuthId m) -- ^ Numeric ID, if used.
|
||||
, credsFacebookToken :: Maybe Facebook.AccessToken
|
||||
}
|
||||
deriving (Show, Read, Eq)
|
||||
|
||||
credsKey :: String
|
||||
credsKey = "_CREDS"
|
||||
credsKey = "_ID"
|
||||
|
||||
setCreds :: YesodAuth master
|
||||
=> Creds -> [(String, String)] -> GHandler Auth master ()
|
||||
=> Creds master -> [(String, String)] -> GHandler Auth master ()
|
||||
setCreds creds extra = do
|
||||
setSession credsKey $ show creds
|
||||
onLogin creds extra
|
||||
maid <- getAuthId creds extra
|
||||
case maid of
|
||||
Nothing -> return ()
|
||||
Just aid -> showAuthId aid >>= setSession credsKey
|
||||
|
||||
-- | Retrieves user credentials, if user is authenticated.
|
||||
maybeCreds :: RequestReader r => r (Maybe Creds)
|
||||
maybeCreds :: YesodAuth m => GHandler s m (Maybe (AuthId m))
|
||||
maybeCreds = do
|
||||
mstring <- lookupSession credsKey
|
||||
return $ mstring >>= readMay
|
||||
where
|
||||
readMay x = case reads x of
|
||||
(y, _):_ -> Just y
|
||||
_ -> Nothing
|
||||
ms <- lookupSession credsKey
|
||||
case ms of
|
||||
Nothing -> return Nothing
|
||||
Just s -> readAuthId s
|
||||
|
||||
mkYesodSub "Auth"
|
||||
[ ClassP ''YesodAuth [VarT $ mkName "master"]
|
||||
@ -188,7 +183,7 @@ mkYesodSub "Auth"
|
||||
testOpenId :: YesodAuth master => GHandler Auth master ()
|
||||
testOpenId = do
|
||||
a <- getYesod
|
||||
unless (authIsOpenIdEnabled a) notFound
|
||||
unless (openIdEnabled a) notFound
|
||||
|
||||
getOpenIdR :: YesodAuth master => GHandler Auth master RepHtml
|
||||
getOpenIdR = do
|
||||
@ -242,7 +237,7 @@ handleRpxnowR :: YesodAuth master => GHandler Auth master ()
|
||||
handleRpxnowR = do
|
||||
ay <- getYesod
|
||||
auth <- getYesod
|
||||
apiKey <- case authRpxnowApiKey auth of
|
||||
apiKey <- case rpxnowApiKey auth of
|
||||
Just x -> return x
|
||||
Nothing -> notFound
|
||||
token1 <- lookupGetParam "token"
|
||||
@ -275,7 +270,7 @@ getDisplayName extra =
|
||||
where
|
||||
choices = ["verifiedEmail", "email", "displayName", "preferredUsername"]
|
||||
|
||||
getCheckR :: Yesod master => GHandler Auth master RepHtmlJson
|
||||
getCheckR :: YesodAuth master => GHandler Auth master RepHtmlJson
|
||||
getCheckR = do
|
||||
creds <- maybeCreds
|
||||
defaultLayoutJson (do
|
||||
@ -285,15 +280,13 @@ getCheckR = do
|
||||
html creds = [$hamlet|
|
||||
%h1 Authentication Status
|
||||
$if isNothing.creds
|
||||
%p Not logged in
|
||||
$maybe creds c
|
||||
%p Logged in as $credsIdent.c$
|
||||
%p Not logged in.
|
||||
$maybe creds _
|
||||
%p Logged in.
|
||||
|]
|
||||
json creds =
|
||||
jsonMap
|
||||
[ ("ident", jsonScalar $ maybe "" credsIdent creds)
|
||||
, ("displayName", jsonScalar $ fromMaybe ""
|
||||
$ creds >>= credsDisplayName)
|
||||
[ ("logged_in", jsonScalar $ maybe "false" (const "true") creds)
|
||||
]
|
||||
|
||||
getLogoutR :: YesodAuth master => GHandler Auth master ()
|
||||
@ -303,20 +296,22 @@ getLogoutR = do
|
||||
redirectUltDest RedirectTemporary $ defaultDest y
|
||||
|
||||
-- | 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.
|
||||
requireCreds :: YesodAuth master => GHandler sub master Creds
|
||||
requireCreds :: YesodAuth m => GHandler sub m (AuthId m)
|
||||
requireCreds =
|
||||
maybeCreds >>= maybe redirectLogin return
|
||||
where
|
||||
redirectLogin = do
|
||||
y <- getYesod
|
||||
setUltDest'
|
||||
redirect RedirectTemporary $ defaultLoginRoute y
|
||||
case authRoute y of
|
||||
Just z -> redirect RedirectTemporary z
|
||||
Nothing -> permissionDenied "Please configure authRoute"
|
||||
|
||||
getAuthEmailSettings :: YesodAuth 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 = do
|
||||
@ -350,7 +345,7 @@ postEmailRegisterR = do
|
||||
return (lid, key)
|
||||
render <- getUrlRender
|
||||
tm <- getRouteToMaster
|
||||
let verUrl = render $ tm $ EmailVerifyR lid verKey
|
||||
let verUrl = render $ tm $ EmailVerifyR (fromIntegral 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$.
|
||||
@ -358,20 +353,25 @@ postEmailRegisterR = do
|
||||
|
||||
getEmailVerifyR :: YesodAuth master
|
||||
=> Integer -> String -> GHandler Auth master RepHtml
|
||||
getEmailVerifyR lid key = do
|
||||
getEmailVerifyR lid' key = do
|
||||
let lid = fromInteger lid'
|
||||
ae <- getAuthEmailSettings
|
||||
realKey <- getVerifyKey ae lid
|
||||
memail <- getEmail ae lid
|
||||
case (realKey == Just key, memail) of
|
||||
(True, Just email) -> do
|
||||
verifyAccount ae lid
|
||||
setCreds (Creds email AuthEmail (Just email) Nothing (Just lid)
|
||||
Nothing) []
|
||||
toMaster <- getRouteToMaster
|
||||
redirect RedirectTemporary $ toMaster EmailPasswordR
|
||||
_ -> defaultLayout $ do
|
||||
setTitle "Invalid verification key"
|
||||
addBody [$hamlet|
|
||||
muid <- verifyAccount ae lid
|
||||
case muid of
|
||||
Nothing -> return ()
|
||||
Just uid -> do
|
||||
setCreds (Creds email AuthEmail (Just email) Nothing (Just uid)
|
||||
Nothing) []
|
||||
toMaster <- getRouteToMaster
|
||||
redirect RedirectTemporary $ toMaster EmailPasswordR
|
||||
_ -> return ()
|
||||
defaultLayout $ do
|
||||
setTitle "Invalid verification key"
|
||||
addBody [$hamlet|
|
||||
%p I'm sorry, but that was an invalid verification key.
|
||||
|]
|
||||
|
||||
@ -411,14 +411,20 @@ postEmailLoginR = do
|
||||
<*> stringInput "password"
|
||||
y <- getYesod
|
||||
mecreds <- getEmailCreds ae email
|
||||
let mlid =
|
||||
case mecreds of
|
||||
Just (EmailCreds lid (Just realpass) True _) ->
|
||||
if isValidPass pass realpass then Just lid else Nothing
|
||||
_ -> Nothing
|
||||
case mlid of
|
||||
Just lid -> do
|
||||
setCreds (Creds email AuthEmail (Just email) Nothing (Just lid)
|
||||
maid <-
|
||||
case (mecreds >>= emailCredsAuthId, fmap emailCredsStatus mecreds) of
|
||||
(Just aid, Just True) -> do
|
||||
mrealpass <- getPassword ae 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 -> do
|
||||
setCreds (Creds email AuthEmail (Just email) Nothing (Just aid)
|
||||
Nothing) []
|
||||
redirectUltDest RedirectTemporary $ defaultDest y
|
||||
Nothing -> do
|
||||
@ -430,18 +436,15 @@ getEmailPasswordR :: YesodAuth master => GHandler Auth master RepHtml
|
||||
getEmailPasswordR = do
|
||||
_ae <- getAuthEmailSettings
|
||||
toMaster <- getRouteToMaster
|
||||
mcreds <- maybeCreds
|
||||
case mcreds of
|
||||
Just (Creds _ AuthEmail _ _ (Just _) _) -> return ()
|
||||
_ -> do
|
||||
maid <- maybeCreds
|
||||
case maid of
|
||||
Just _ -> return ()
|
||||
Nothing -> do
|
||||
setMessage $ string "You must be logged in to set a password"
|
||||
redirect RedirectTemporary $ toMaster EmailLoginR
|
||||
msg <- getMessage
|
||||
defaultLayout $ do
|
||||
setTitle "Set password"
|
||||
addBody [$hamlet|
|
||||
$maybe msg ms
|
||||
%p.message $ms$
|
||||
%h3 Set a new password
|
||||
%form!method=post!action=@toMaster.EmailPasswordR@
|
||||
%table
|
||||
@ -468,16 +471,17 @@ postEmailPasswordR = do
|
||||
when (new /= confirm) $ do
|
||||
setMessage $ string "Passwords did not match, please try again"
|
||||
redirect RedirectTemporary $ toMaster EmailPasswordR
|
||||
mcreds <- maybeCreds
|
||||
lid <- case mcreds of
|
||||
Just (Creds _ AuthEmail _ _ (Just lid) _) -> return lid
|
||||
_ -> do
|
||||
maid <- maybeCreds
|
||||
aid <- case maid of
|
||||
Nothing -> do
|
||||
setMessage $ string "You must be logged in to set a password"
|
||||
redirect RedirectTemporary $ toMaster EmailLoginR
|
||||
Just aid -> return aid
|
||||
salted <- liftIO $ saltPass new
|
||||
setPassword ae lid salted
|
||||
setPassword ae aid salted
|
||||
setMessage $ string "Password updated"
|
||||
redirect RedirectTemporary $ toMaster EmailLoginR
|
||||
y <- getYesod
|
||||
redirect RedirectTemporary $ defaultDest y
|
||||
|
||||
saltLength :: Int
|
||||
saltLength = 5
|
||||
@ -498,47 +502,10 @@ saltPass pass = do
|
||||
saltPass' :: String -> String -> String
|
||||
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 = do
|
||||
y <- getYesod
|
||||
a <- authFacebook <$> getYesod
|
||||
a <- facebookKeys <$> getYesod
|
||||
case a of
|
||||
Nothing -> notFound
|
||||
Just (cid, secret, _) -> do
|
||||
@ -561,7 +528,7 @@ getFacebookR = do
|
||||
getStartFacebookR :: YesodAuth master => GHandler Auth master ()
|
||||
getStartFacebookR = do
|
||||
y <- getYesod
|
||||
case authFacebook y of
|
||||
case facebookKeys y of
|
||||
Nothing -> notFound
|
||||
Just (cid, secret, perms) -> do
|
||||
render <- getUrlRender
|
||||
@ -569,33 +536,3 @@ getStartFacebookR = do
|
||||
let fb = Facebook.Facebook cid secret $ render $ tm FacebookR
|
||||
let fburl = Facebook.getForwardUrl fb perms
|
||||
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)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user