diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index dda02c6e..51407c94 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -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)