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

Minor fixes for the auth module

Browse Source
This commit is contained in:
Michael Snoyman 2010-08-17 23:58:29 +03:00
parent cfffdd9cb3
commit 799ee875f6
1 changed files with 23 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
Yesod/Helpers/Auth.hs
View File

@ -100,7 +100,12 @@ 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 EmailId (Maybe SaltedPass) VerStatus VerKey data EmailCreds = EmailCreds
{ emailCredsId :: EmailId
, emailCredsPass :: Maybe SaltedPass
, emailCredsStatus :: VerStatus
, emailCredsVerkey :: Maybe VerKey
}
-- | 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'.
@ -108,6 +113,7 @@ data AuthEmailSettings = AuthEmailSettings
{ addUnverified :: Email -> VerKey -> IO EmailId { addUnverified :: Email -> VerKey -> IO EmailId
, sendVerifyEmail :: Email -> VerKey -> VerUrl -> IO () , sendVerifyEmail :: Email -> VerKey -> VerUrl -> IO ()
, getVerifyKey :: EmailId -> IO (Maybe VerKey) , getVerifyKey :: EmailId -> IO (Maybe VerKey)
, setVerifyKey :: EmailId -> VerKey -> IO ()
, verifyAccount :: EmailId -> IO () , verifyAccount :: EmailId -> IO ()
, setPassword :: EmailId -> String -> IO () , setPassword :: EmailId -> String -> IO ()
, getEmailCreds :: Email -> IO (Maybe EmailCreds) , getEmailCreds :: Email -> IO (Maybe EmailCreds)
@ -148,11 +154,11 @@ mkYesodSub "Auth"
[ ClassP ''YesodAuth [VarT $ mkName "master"] [ ClassP ''YesodAuth [VarT $ mkName "master"]
] ]
[$parseRoutes| [$parseRoutes|
/check Check GET /check CheckR GET
/logout Logout GET /logout LogoutR GET
/openid OpenIdR GET /openid OpenIdR GET
/openid/forward OpenIdForward GET /openid/forward OpenIdForwardR GET
/openid/complete OpenIdComplete GET /openid/complete OpenIdCompleteR GET
/login/rpxnow RpxnowR /login/rpxnow RpxnowR
/facebook FacebookR GET /facebook FacebookR GET
@ -312,11 +318,15 @@ postEmailRegisterR = do
mecreds <- liftIO $ getEmailCreds ae email mecreds <- liftIO $ getEmailCreds ae email
(lid, verKey) <- (lid, verKey) <-
case mecreds of case mecreds of
Just (EmailCreds lid _ _ (Just key)) -> return (lid, key)
Just (EmailCreds lid _ _ Nothing) -> liftIO $ do
key <- randomKey y
setVerifyKey ae lid key
return (lid, key)
Nothing -> liftIO $ do Nothing -> liftIO $ do
key <- randomKey y key <- randomKey y
lid <- addUnverified ae email key lid <- addUnverified ae email key
return (lid, key) return (lid, key)
Just (EmailCreds 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 lid verKey
@ -471,12 +481,14 @@ inMemoryEmailSettings = do
{ addUnverified = \email verkey -> modifyMVar mm $ \m -> do { addUnverified = \email verkey -> modifyMVar mm $ \m -> do
let helper (_, EmailCreds x _ _ _) = x let helper (_, EmailCreds x _ _ _) = x
let newId = 1 + maximum (0 : map helper m) let newId = 1 + maximum (0 : map helper m)
let ec = EmailCreds newId Nothing False verkey let ec = EmailCreds newId Nothing False $ Just verkey
return ((email, ec) : m, newId) return ((email, ec) : m, newId)
, sendVerifyEmail = \_email _verkey verurl -> , sendVerifyEmail = \_email _verkey verurl ->
hPutStrLn stderr $ "Please go to: " ++ verurl hPutStrLn stderr $ "Please go to: " ++ verurl
, getVerifyKey = \eid -> withMVar mm $ \m -> return $ , getVerifyKey = \eid -> withMVar mm $ \m -> return $
lookup eid $ map (\(_, EmailCreds eid' _ _ vk) -> (eid', vk)) m join $ lookup eid $ map (\(_, EmailCreds eid' _ _ vk) -> (eid', vk)) m
, setVerifyKey = \eid key -> modifyMVar_ mm $ \m -> return $
map (setHelper eid key) m
, verifyAccount = \eid -> modifyMVar_ mm $ return . map (vago eid) , verifyAccount = \eid -> modifyMVar_ mm $ return . map (vago eid)
, setPassword = \eid pass -> modifyMVar_ mm $ return . map (spgo eid pass) , setPassword = \eid pass -> modifyMVar_ mm $ return . map (spgo eid pass)
, getEmailCreds = \email -> withMVar mm $ return . lookup email , getEmailCreds = \email -> withMVar mm $ return . lookup email
@ -486,6 +498,9 @@ inMemoryEmailSettings = do
_ -> Nothing _ -> Nothing
} }
where 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) vago eid (email, EmailCreds eid' pass status key)
| eid == eid' = (email, EmailCreds eid pass True key) | eid == eid' = (email, EmailCreds eid pass True key)
| otherwise = (email, EmailCreds eid' pass status key) | otherwise = (email, EmailCreds eid' pass status key)