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

Auth -> Auth master

Browse Source
This commit is contained in:
Michael Snoyman 2010-08-19 09:45:07 +03:00
parent f7dc45eb9e
commit 6bef4e5018
1 changed files with 51 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

102
Yesod/Helpers/Auth.hs
View File

@ -66,24 +66,24 @@ 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 () onLogin :: Creds -> [(String, String)] -> GHandler (Auth master) master ()
onLogin _ _ = return () onLogin _ _ = return ()
-- | Generate a random alphanumeric string. -- | Generate a random alphanumeric string.
-- --
-- This is used for verify string in email authentication. -- This is used for verify string in email authentication.
randomKey :: master -> IO String randomKey :: master -> GHandler (Auth master) master String
randomKey _ = do randomKey _ = liftIO $ do
stdgen <- newStdGen stdgen <- newStdGen
return $ take 10 $ randomRs ('A', 'Z') stdgen return $ take 10 $ randomRs ('A', 'Z') stdgen
-- | Each authentication subsystem (OpenId, Rpxnow, Email, Facebook) has its -- | Each authentication subsystem (OpenId, Rpxnow, Email, Facebook) has its
-- own settings. If those settings are not present, then relevant handlers will -- own settings. If those settings are not present, then relevant handlers will
-- simply return a 404. -- simply return a 404.
data Auth = Auth data Auth m = Auth
{ authIsOpenIdEnabled :: Bool { authIsOpenIdEnabled :: Bool
, authRpxnowApiKey :: Maybe String , authRpxnowApiKey :: Maybe String
, authEmailSettings :: Maybe AuthEmailSettings , authEmailSettings :: Maybe (AuthEmailSettings m)
-- | client id, secret and requested permissions -- | client id, secret and requested permissions
, authFacebook :: Maybe (String, String, [String]) , authFacebook :: Maybe (String, String, [String])
} }
@ -109,15 +109,15 @@ 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 = AuthEmailSettings data AuthEmailSettings m = AuthEmailSettings
{ addUnverified :: Email -> VerKey -> IO EmailId { addUnverified :: Email -> VerKey -> GHandler (Auth m) m EmailId
, sendVerifyEmail :: Email -> VerKey -> VerUrl -> IO () , sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler (Auth m) m ()
, getVerifyKey :: EmailId -> IO (Maybe VerKey) , getVerifyKey :: EmailId -> GHandler (Auth m) m (Maybe VerKey)
, setVerifyKey :: EmailId -> VerKey -> IO () , setVerifyKey :: EmailId -> VerKey -> GHandler (Auth m) m ()
, verifyAccount :: EmailId -> IO () , verifyAccount :: EmailId -> GHandler (Auth m) m ()
, setPassword :: EmailId -> String -> IO () , setPassword :: EmailId -> String -> GHandler (Auth m) m ()
, getEmailCreds :: Email -> IO (Maybe EmailCreds) , getEmailCreds :: Email -> GHandler (Auth m) m (Maybe EmailCreds)
, getEmail :: EmailId -> IO (Maybe Email) , getEmail :: EmailId -> GHandler (Auth m) m (Maybe Email)
} }
-- | User credentials -- | User credentials
@ -135,7 +135,7 @@ credsKey :: String
credsKey = "_CREDS" credsKey = "_CREDS"
setCreds :: YesodAuth master setCreds :: YesodAuth master
=> Creds -> [(String, String)] -> GHandler Auth master () => Creds -> [(String, String)] -> GHandler (Auth master) master ()
setCreds creds extra = do setCreds creds extra = do
setSession credsKey $ show creds setSession credsKey $ show creds
onLogin creds extra onLogin creds extra
@ -150,7 +150,7 @@ maybeCreds = do
(y, _):_ -> Just y (y, _):_ -> Just y
_ -> Nothing _ -> Nothing
mkYesodSub "Auth" mkYesodSub "Auth master"
[ ClassP ''YesodAuth [VarT $ mkName "master"] [ ClassP ''YesodAuth [VarT $ mkName "master"]
] ]
[$parseRoutes| [$parseRoutes|
@ -170,12 +170,12 @@ mkYesodSub "Auth"
/set-password EmailPasswordR GET POST /set-password EmailPasswordR GET POST
|] |]
testOpenId :: GHandler Auth master () testOpenId :: GHandler (Auth master) master ()
testOpenId = do testOpenId = do
a <- getYesodSub a <- getYesodSub
unless (authIsOpenIdEnabled a) notFound unless (authIsOpenIdEnabled a) notFound
getOpenIdR :: Yesod master => GHandler Auth master RepHtml getOpenIdR :: Yesod master => GHandler (Auth master) master RepHtml
getOpenIdR = do getOpenIdR = do
testOpenId testOpenId
lookupGetParam "dest" >>= maybe (return ()) setUltDestString lookupGetParam "dest" >>= maybe (return ()) setUltDestString
@ -190,7 +190,7 @@ $maybe message msg
%input!type=submit!value=Login %input!type=submit!value=Login
|] |]
getOpenIdForwardR :: GHandler Auth master () getOpenIdForwardR :: GHandler (Auth master) master ()
getOpenIdForwardR = do getOpenIdForwardR = do
testOpenId testOpenId
oid <- runFormGet' $ stringInput "openid" oid <- runFormGet' $ stringInput "openid"
@ -205,7 +205,7 @@ getOpenIdForwardR = do
(redirectString RedirectTemporary) (redirectString RedirectTemporary)
res res
getOpenIdCompleteR :: YesodAuth master => GHandler Auth master () getOpenIdCompleteR :: YesodAuth master => GHandler (Auth master) master ()
getOpenIdCompleteR = do getOpenIdCompleteR = do
testOpenId testOpenId
rr <- getRequest rr <- getRequest
@ -221,7 +221,7 @@ getOpenIdCompleteR = do
redirectUltDest RedirectTemporary $ defaultDest y redirectUltDest RedirectTemporary $ defaultDest y
attempt onFailure onSuccess res attempt onFailure onSuccess res
handleRpxnowR :: YesodAuth master => GHandler Auth master () handleRpxnowR :: YesodAuth master => GHandler (Auth master) master ()
handleRpxnowR = do handleRpxnowR = do
ay <- getYesod ay <- getYesod
auth <- getYesodSub auth <- getYesodSub
@ -258,7 +258,7 @@ getDisplayName extra =
where where
choices = ["verifiedEmail", "email", "displayName", "preferredUsername"] choices = ["verifiedEmail", "email", "displayName", "preferredUsername"]
getCheckR :: Yesod master => GHandler Auth master RepHtmlJson getCheckR :: Yesod master => GHandler (Auth master) master RepHtmlJson
getCheckR = do getCheckR = do
creds <- maybeCreds creds <- maybeCreds
applyLayoutJson "Authentication Status" mempty (html creds) (json creds) applyLayoutJson "Authentication Status" mempty (html creds) (json creds)
@ -277,7 +277,7 @@ $maybe creds c
$ creds >>= credsDisplayName) $ creds >>= credsDisplayName)
] ]
getLogoutR :: YesodAuth master => GHandler Auth master () getLogoutR :: YesodAuth master => GHandler (Auth master) master ()
getLogoutR = do getLogoutR = do
y <- getYesod y <- getYesod
deleteSession credsKey deleteSession credsKey
@ -295,10 +295,10 @@ requireCreds =
setUltDest' setUltDest'
redirect RedirectTemporary $ defaultLoginRoute y redirect RedirectTemporary $ defaultLoginRoute y
getAuthEmailSettings :: GHandler Auth master AuthEmailSettings getAuthEmailSettings :: GHandler (Auth master) master (AuthEmailSettings master)
getAuthEmailSettings = getYesodSub >>= maybe notFound return . authEmailSettings getAuthEmailSettings = getYesodSub >>= maybe notFound return . authEmailSettings
getEmailRegisterR :: Yesod master => GHandler Auth master RepHtml getEmailRegisterR :: Yesod master => GHandler (Auth master) master RepHtml
getEmailRegisterR = do getEmailRegisterR = do
_ae <- getAuthEmailSettings _ae <- getAuthEmailSettings
toMaster <- getRouteToMaster toMaster <- getRouteToMaster
@ -310,40 +310,40 @@ getEmailRegisterR = do
%input!type=submit!value=Register %input!type=submit!value=Register
|] |]
postEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml postEmailRegisterR :: YesodAuth master => GHandler (Auth master) master RepHtml
postEmailRegisterR = do postEmailRegisterR = do
ae <- getAuthEmailSettings ae <- getAuthEmailSettings
email <- runFormPost' $ emailInput "email" email <- runFormPost' $ emailInput "email"
y <- getYesod y <- getYesod
mecreds <- liftIO $ getEmailCreds ae email mecreds <- getEmailCreds ae email
(lid, verKey) <- (lid, verKey) <-
case mecreds of case mecreds of
Just (EmailCreds lid _ _ (Just key)) -> return (lid, key) Just (EmailCreds lid _ _ (Just key)) -> return (lid, key)
Just (EmailCreds lid _ _ Nothing) -> liftIO $ do Just (EmailCreds lid _ _ Nothing) -> do
key <- randomKey y key <- randomKey y
setVerifyKey ae lid key setVerifyKey ae lid key
return (lid, key) return (lid, key)
Nothing -> liftIO $ do Nothing -> do
key <- randomKey y key <- randomKey y
lid <- addUnverified ae email key lid <- addUnverified ae email key
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 lid verKey
liftIO $ sendVerifyEmail ae email verKey verUrl sendVerifyEmail ae email verKey verUrl
applyLayout "Confirmation e-mail sent" mempty [$hamlet| applyLayout "Confirmation e-mail sent" mempty [$hamlet|
%p A confirmation e-mail has been sent to $email$. %p A confirmation e-mail has been sent to $email$.
|] |]
getEmailVerifyR :: YesodAuth master getEmailVerifyR :: YesodAuth master
=> Integer -> String -> GHandler Auth master RepHtml => Integer -> String -> GHandler (Auth master) master RepHtml
getEmailVerifyR lid key = do getEmailVerifyR lid key = do
ae <- getAuthEmailSettings ae <- getAuthEmailSettings
realKey <- liftIO $ getVerifyKey ae lid realKey <- getVerifyKey ae lid
memail <- liftIO $ 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
liftIO $ verifyAccount ae lid verifyAccount ae lid
setCreds (Creds email AuthEmail (Just email) Nothing (Just lid) setCreds (Creds email AuthEmail (Just email) Nothing (Just lid)
Nothing) [] Nothing) []
toMaster <- getRouteToMaster toMaster <- getRouteToMaster
@ -352,7 +352,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 RepHtml getEmailLoginR :: Yesod master => GHandler (Auth master) master RepHtml
getEmailLoginR = do getEmailLoginR = do
_ae <- getAuthEmailSettings _ae <- getAuthEmailSettings
toMaster <- getRouteToMaster toMaster <- getRouteToMaster
@ -378,14 +378,14 @@ $maybe msg ms
%input!type=submit!value=Login %input!type=submit!value=Login
|] |]
postEmailLoginR :: YesodAuth master => GHandler Auth master () postEmailLoginR :: YesodAuth master => GHandler (Auth master) master ()
postEmailLoginR = do postEmailLoginR = do
ae <- getAuthEmailSettings ae <- getAuthEmailSettings
(email, pass) <- runFormPost' $ (,) (email, pass) <- runFormPost' $ (,)
<$> emailInput "email" <$> emailInput "email"
<*> stringInput "password" <*> stringInput "password"
y <- getYesod y <- getYesod
mecreds <- liftIO $ getEmailCreds ae email mecreds <- getEmailCreds ae email
let mlid = let mlid =
case mecreds of case mecreds of
Just (EmailCreds lid (Just realpass) True _) -> Just (EmailCreds lid (Just realpass) True _) ->
@ -401,7 +401,7 @@ postEmailLoginR = do
toMaster <- getRouteToMaster toMaster <- getRouteToMaster
redirect RedirectTemporary $ toMaster EmailLoginR redirect RedirectTemporary $ toMaster EmailLoginR
getEmailPasswordR :: Yesod master => GHandler Auth master RepHtml getEmailPasswordR :: Yesod master => GHandler (Auth master) master RepHtml
getEmailPasswordR = do getEmailPasswordR = do
_ae <- getAuthEmailSettings _ae <- getAuthEmailSettings
toMaster <- getRouteToMaster toMaster <- getRouteToMaster
@ -431,7 +431,7 @@ $maybe msg ms
%input!type=submit!value=Submit %input!type=submit!value=Submit
|] |]
postEmailPasswordR :: YesodAuth master => GHandler Auth master () postEmailPasswordR :: YesodAuth master => GHandler (Auth master) master ()
postEmailPasswordR = do postEmailPasswordR = do
ae <- getAuthEmailSettings ae <- getAuthEmailSettings
(new, confirm) <- runFormPost' $ (,) (new, confirm) <- runFormPost' $ (,)
@ -448,7 +448,7 @@ postEmailPasswordR = 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
salted <- liftIO $ saltPass new salted <- liftIO $ saltPass new
liftIO $ setPassword ae lid salted setPassword ae lid salted
setMessage $ string "Password updated" setMessage $ string "Password updated"
redirect RedirectTemporary $ toMaster EmailLoginR redirect RedirectTemporary $ toMaster EmailLoginR
@ -474,25 +474,25 @@ saltPass' salt pass = salt ++ show (md5 $ fromString $ salt ++ pass)
-- | A simplistic set of email settings, useful only for testing purposes. In -- | A simplistic set of email settings, useful only for testing purposes. In
-- particular, it doesn't actually send emails, but instead prints verification -- particular, it doesn't actually send emails, but instead prints verification
-- URLs to stderr. -- URLs to stderr.
inMemoryEmailSettings :: IO AuthEmailSettings inMemoryEmailSettings :: IO (AuthEmailSettings a)
inMemoryEmailSettings = do inMemoryEmailSettings = do
mm <- newMVar [] mm <- newMVar []
return AuthEmailSettings return AuthEmailSettings
{ addUnverified = \email verkey -> modifyMVar mm $ \m -> do { addUnverified = \email verkey -> liftIO $ 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 $ Just 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 -> liftIO $
hPutStrLn stderr $ "Please go to: " ++ verurl hPutStrLn stderr $ "Please go to: " ++ verurl
, getVerifyKey = \eid -> withMVar mm $ \m -> return $ , getVerifyKey = \eid -> liftIO $ withMVar mm $ \m -> return $
join $ 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 $ , setVerifyKey = \eid key -> liftIO $ modifyMVar_ mm $ \m -> return $
map (setHelper eid key) m map (setHelper eid key) m
, verifyAccount = \eid -> modifyMVar_ mm $ return . map (vago eid) , verifyAccount = \eid -> liftIO $ modifyMVar_ mm $ return . map (vago eid)
, setPassword = \eid pass -> modifyMVar_ mm $ return . map (spgo eid pass) , setPassword = \eid pass -> liftIO $ modifyMVar_ mm $ return . map (spgo eid pass)
, getEmailCreds = \email -> withMVar mm $ return . lookup email , getEmailCreds = \email -> liftIO $ withMVar mm $ return . lookup email
, getEmail = \eid -> withMVar mm $ \m -> return $ , getEmail = \eid -> liftIO $ withMVar mm $ \m -> return $
case filter (\(_, EmailCreds eid' _ _ _) -> eid == eid') m of case filter (\(_, EmailCreds eid' _ _ _) -> eid == eid') m of
((email, _):_) -> Just email ((email, _):_) -> Just email
_ -> Nothing _ -> Nothing
@ -508,7 +508,7 @@ 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 () getFacebookR :: YesodAuth master => GHandler (Auth master) master ()
getFacebookR = do getFacebookR = do
y <- getYesod y <- getYesod
a <- authFacebook <$> getYesodSub a <- authFacebook <$> getYesodSub
@ -531,7 +531,7 @@ getFacebookR = do
setCreds c [] setCreds c []
redirectUltDest RedirectTemporary $ defaultDest y redirectUltDest RedirectTemporary $ defaultDest y
getStartFacebookR :: GHandler Auth master () getStartFacebookR :: GHandler (Auth master) master ()
getStartFacebookR = do getStartFacebookR = do
y <- getYesodSub y <- getYesodSub
case authFacebook y of case authFacebook y of