Initial source pull from Yesod newauth branch
This commit is contained in:
Michael Snoyman
parent
914e0f5acc
commit
559f9d53d9
4
.gitignore
vendored
Normal file
4
.gitignore
vendored
Normal file
@ -0,0 +1,4 @@
|
||||
dist
|
||||
*.swp
|
||||
auth2.db3
|
||||
client_session_key.aes
|
||||
25
LICENSE
Normal file
25
LICENSE
Normal file
@ -0,0 +1,25 @@
|
||||
The following license covers this documentation, and the source code, except
|
||||
where otherwise indicated.
|
||||
|
||||
Copyright 2010, Michael Snoyman. All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright notice, this
|
||||
list of conditions and the following disclaimer.
|
||||
|
||||
* Redistributions in binary form must reproduce the above copyright notice,
|
||||
this list of conditions and the following disclaimer in the documentation
|
||||
and/or other materials provided with the distribution.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
|
||||
IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
|
||||
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
|
||||
EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
|
||||
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
|
||||
NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
|
||||
OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
|
||||
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
|
||||
OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
|
||||
ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
200
Yesod/Helpers/Auth2.hs
Normal file
200
Yesod/Helpers/Auth2.hs
Normal file
@ -0,0 +1,200 @@
|
||||
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
module Yesod.Helpers.Auth2
|
||||
( Auth
|
||||
, AuthPlugin (..)
|
||||
, AuthRoute (..)
|
||||
, getAuth
|
||||
, Creds (..)
|
||||
, YesodAuth (..)
|
||||
, setCreds
|
||||
, maybeAuthId
|
||||
, maybeAuth
|
||||
, requireAuthId
|
||||
, requireAuth
|
||||
, authDummy
|
||||
) where
|
||||
|
||||
import Yesod
|
||||
import Language.Haskell.TH.Syntax hiding (lift)
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import qualified Network.Wai as W
|
||||
|
||||
data Auth = Auth
|
||||
|
||||
type Method = String
|
||||
type Piece = String
|
||||
|
||||
data AuthPlugin m = AuthPlugin
|
||||
{ apName :: String
|
||||
, apDispatch :: Method -> [Piece] -> GHandler Auth m ()
|
||||
, apLogin :: GWidget Auth m ()
|
||||
}
|
||||
|
||||
getAuth :: a -> Auth
|
||||
getAuth = const Auth
|
||||
|
||||
-- | User credentials
|
||||
data Creds m = Creds
|
||||
{ credsPlugin :: String -- ^ How the user was authenticated
|
||||
, credsIdent :: String -- ^ Identifier. Exact meaning depends on plugin.
|
||||
, credsExtra :: [(String, String)]
|
||||
}
|
||||
|
||||
class Yesod m => YesodAuth m where
|
||||
type AuthId m
|
||||
|
||||
-- | Default destination on successful login or logout, if no other
|
||||
-- destination exists.
|
||||
defaultDest :: m -> Route m
|
||||
|
||||
getAuthId :: Creds m -> GHandler s m (Maybe (AuthId m))
|
||||
|
||||
showAuthId :: m -> AuthId m -> String
|
||||
readAuthId :: m -> String -> Maybe (AuthId m)
|
||||
|
||||
authPlugins :: [AuthPlugin m]
|
||||
|
||||
mkYesodSub "Auth"
|
||||
[ ClassP ''YesodAuth [VarT $ mkName "master"]
|
||||
] [$parseRoutes|
|
||||
/check CheckR GET
|
||||
/login LoginR GET
|
||||
/logout LogoutR GET POST
|
||||
/page/#String/*Strings PluginR
|
||||
|]
|
||||
|
||||
credsKey :: String
|
||||
credsKey = "_ID"
|
||||
|
||||
setCreds :: YesodAuth m => Bool -> Creds m -> GHandler s m ()
|
||||
setCreds doRedirects creds = do
|
||||
y <- getYesod
|
||||
maid <- getAuthId creds
|
||||
case maid of
|
||||
Nothing ->
|
||||
if doRedirects
|
||||
then do
|
||||
case authRoute y of
|
||||
Nothing -> do
|
||||
rh <- defaultLayout $ addBody [$hamlet|
|
||||
%h1 Invalid login
|
||||
|]
|
||||
sendResponse rh
|
||||
Just ar -> do
|
||||
setMessage $ string "Invalid login"
|
||||
redirect RedirectTemporary ar
|
||||
else return ()
|
||||
Just aid -> do
|
||||
setSession credsKey $ showAuthId y aid
|
||||
if doRedirects
|
||||
then do
|
||||
setMessage $ string "You are now logged in"
|
||||
redirect RedirectTemporary $ defaultDest y
|
||||
else return ()
|
||||
|
||||
getCheckR :: YesodAuth m => GHandler Auth m RepHtmlJson
|
||||
getCheckR = do
|
||||
creds <- maybeAuthId
|
||||
defaultLayoutJson (do
|
||||
setTitle $ string "Authentication Status"
|
||||
addBody $ html creds) (json creds)
|
||||
where
|
||||
html creds = [$hamlet|
|
||||
%h1 Authentication Status
|
||||
$maybe creds _
|
||||
%p Logged in.
|
||||
$nothing
|
||||
%p Not logged in.
|
||||
|]
|
||||
json creds =
|
||||
jsonMap
|
||||
[ ("logged_in", jsonScalar $ maybe "false" (const "true") creds)
|
||||
]
|
||||
|
||||
getLoginR :: YesodAuth m => GHandler Auth m RepHtml
|
||||
getLoginR = defaultLayout $ do
|
||||
setTitle $ string "Login"
|
||||
mapM_ apLogin authPlugins
|
||||
|
||||
getLogoutR :: YesodAuth m => GHandler Auth m ()
|
||||
getLogoutR = postLogoutR -- FIXME redirect to post
|
||||
|
||||
postLogoutR :: YesodAuth m => GHandler Auth m ()
|
||||
postLogoutR = do
|
||||
y <- getYesod
|
||||
deleteSession credsKey
|
||||
redirectUltDest RedirectTemporary $ defaultDest y
|
||||
|
||||
handlePluginR :: YesodAuth m => String -> [String] -> GHandler Auth m ()
|
||||
handlePluginR plugin pieces = do
|
||||
env <- waiRequest
|
||||
let method = S8.unpack $ W.requestMethod env
|
||||
case filter (\x -> apName x == plugin) authPlugins of
|
||||
[] -> notFound
|
||||
ap:_ -> apDispatch ap method pieces
|
||||
|
||||
-- | Retrieves user credentials, if user is authenticated.
|
||||
maybeAuthId :: YesodAuth m => GHandler s m (Maybe (AuthId m))
|
||||
maybeAuthId = do
|
||||
ms <- lookupSession credsKey
|
||||
y <- getYesod
|
||||
case ms of
|
||||
Nothing -> return Nothing
|
||||
Just s -> return $ readAuthId y s
|
||||
|
||||
maybeAuth :: ( YesodAuth m
|
||||
, Key val ~ AuthId m
|
||||
, PersistBackend (YesodDB m (GHandler s m))
|
||||
, PersistEntity val
|
||||
, YesodPersist m
|
||||
) => GHandler s m (Maybe (Key val, val))
|
||||
maybeAuth = do
|
||||
maid <- maybeAuthId
|
||||
case maid of
|
||||
Nothing -> return Nothing
|
||||
Just aid -> do
|
||||
ma <- runDB $ get aid
|
||||
case ma of
|
||||
Nothing -> return Nothing
|
||||
Just a -> return $ Just (aid, a)
|
||||
|
||||
requireAuthId :: YesodAuth m => GHandler s m (AuthId m)
|
||||
requireAuthId = maybeAuthId >>= maybe redirectLogin return
|
||||
|
||||
requireAuth :: ( YesodAuth m
|
||||
, Key val ~ AuthId m
|
||||
, PersistBackend (YesodDB m (GHandler s m))
|
||||
, PersistEntity val
|
||||
, YesodPersist m
|
||||
) => GHandler s m (Key val, val)
|
||||
requireAuth = maybeAuth >>= maybe redirectLogin return
|
||||
|
||||
redirectLogin :: Yesod m => GHandler s m a
|
||||
redirectLogin = do
|
||||
y <- getYesod
|
||||
setUltDest'
|
||||
case authRoute y of
|
||||
Just z -> redirect RedirectTemporary z
|
||||
Nothing -> permissionDenied "Please configure authRoute"
|
||||
|
||||
authDummy :: YesodAuth m => AuthPlugin m
|
||||
authDummy =
|
||||
AuthPlugin "dummy" dispatch login
|
||||
where
|
||||
dispatch "POST" [] = do
|
||||
ident <- runFormPost' $ stringInput "ident"
|
||||
setCreds True $ Creds "dummy" ident []
|
||||
dispatch _ _ = notFound
|
||||
url = PluginR "dummy" []
|
||||
authToMaster = liftHandler getRouteToMaster
|
||||
login = do
|
||||
tm <- authToMaster
|
||||
addBody [$hamlet|
|
||||
%form!method=post!action=@tm.url@
|
||||
Your new identifier is: $
|
||||
%input!type=text!name=ident
|
||||
%input!type=submit!value="Dummy Login"
|
||||
|]
|
||||
251
Yesod/Helpers/Auth2/Email.hs
Normal file
251
Yesod/Helpers/Auth2/Email.hs
Normal file
@ -0,0 +1,251 @@
|
||||
{-# LANGUAGE QuasiQuotes, TypeFamilies #-}
|
||||
module Yesod.Helpers.Auth2.Email
|
||||
( authEmail
|
||||
, YesodAuthEmail (..)
|
||||
, EmailCreds (..)
|
||||
) where
|
||||
|
||||
import Yesod
|
||||
import Yesod.Mail (randomString)
|
||||
import Yesod.Helpers.Auth2
|
||||
import System.Random
|
||||
import Control.Monad (when)
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
import Data.Digest.Pure.MD5
|
||||
import Data.String (fromString)
|
||||
import qualified Data.ByteString.Lazy.UTF8 as LU
|
||||
|
||||
login, register, setpass :: AuthRoute
|
||||
login = PluginR "email" ["login"]
|
||||
register = PluginR "email" ["register"]
|
||||
setpass = PluginR "email" ["set-password"]
|
||||
|
||||
verify :: String -> String -> AuthRoute -- FIXME
|
||||
verify eid verkey = PluginR "email" ["verify", eid, verkey]
|
||||
|
||||
type Email = String
|
||||
type VerKey = String
|
||||
type VerUrl = String
|
||||
type SaltedPass = String
|
||||
type VerStatus = Bool
|
||||
|
||||
-- | Data stored in a database for each e-mail address.
|
||||
data EmailCreds m = EmailCreds
|
||||
{ emailCredsId :: AuthEmailId m
|
||||
, emailCredsAuthId :: Maybe (AuthId m)
|
||||
, emailCredsStatus :: VerStatus
|
||||
, emailCredsVerkey :: Maybe VerKey
|
||||
}
|
||||
|
||||
class YesodAuth m => YesodAuthEmail m where
|
||||
type AuthEmailId m
|
||||
|
||||
showAuthEmailId :: m -> AuthEmailId m -> String
|
||||
readAuthEmailId :: m -> String -> Maybe (AuthEmailId m)
|
||||
|
||||
addUnverified :: Email -> VerKey -> GHandler Auth m (AuthEmailId m)
|
||||
sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler Auth m ()
|
||||
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)
|
||||
|
||||
-- | Generate a random alphanumeric string.
|
||||
randomKey :: m -> IO String
|
||||
randomKey _ = do
|
||||
stdgen <- newStdGen
|
||||
return $ fst $ randomString 10 stdgen
|
||||
|
||||
authEmail :: YesodAuthEmail m => AuthPlugin m
|
||||
authEmail =
|
||||
AuthPlugin "email" dispatch login'
|
||||
where
|
||||
go x = x >>= sendResponse
|
||||
dispatch "GET" ["register"] = go getRegisterR
|
||||
dispatch "POST" ["register"] = go postRegisterR
|
||||
dispatch "GET" ["verify", eid, verkey] = do
|
||||
y <- getYesod
|
||||
case readAuthEmailId y eid of
|
||||
Nothing -> notFound
|
||||
Just eid' -> go $ getVerifyR eid' verkey
|
||||
dispatch "POST" ["login"] = go postLoginR
|
||||
dispatch "GET" ["set-password"] = go getPasswordR
|
||||
dispatch "POST" ["set-password"] = go postPasswordR
|
||||
dispatch _ _ = notFound
|
||||
|
||||
login' = do
|
||||
tm <- liftHandler getRouteToMaster
|
||||
addBody [$hamlet|
|
||||
%form!method=post!action=@tm.login@
|
||||
%table
|
||||
%tr
|
||||
%th E-mail
|
||||
%td
|
||||
%input!type=email!name=email
|
||||
%tr
|
||||
%th Password
|
||||
%td
|
||||
%input!type=password!name=password
|
||||
%tr
|
||||
%td!colspan=2
|
||||
%input!type=submit!value="Login via email"
|
||||
%a!href=@tm.register@ I don't have an account
|
||||
|]
|
||||
|
||||
getRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml
|
||||
getRegisterR = do
|
||||
toMaster <- getRouteToMaster
|
||||
defaultLayout $ do
|
||||
setTitle $ string "Register a new account"
|
||||
addBody [$hamlet|
|
||||
%p Enter your e-mail address below, and a confirmation e-mail will be sent to you.
|
||||
%form!method=post!action=@toMaster.register@
|
||||
%label!for=email E-mail
|
||||
%input#email!type=email!name=email!width=150
|
||||
%input!type=submit!value=Register
|
||||
|]
|
||||
|
||||
postRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml
|
||||
postRegisterR = do
|
||||
y <- getYesod
|
||||
email <- runFormPost' $ emailInput "email"
|
||||
mecreds <- getEmailCreds email
|
||||
(lid, verKey) <-
|
||||
case mecreds of
|
||||
Just (EmailCreds lid _ _ (Just key)) -> return (lid, key)
|
||||
Just (EmailCreds lid _ _ Nothing) -> do
|
||||
key <- liftIO $ randomKey y
|
||||
setVerifyKey lid key
|
||||
return (lid, key)
|
||||
Nothing -> do
|
||||
key <- liftIO $ randomKey y
|
||||
lid <- addUnverified email key
|
||||
return (lid, key)
|
||||
render <- getUrlRender
|
||||
tm <- getRouteToMaster
|
||||
let verUrl = render $ tm $ verify (showAuthEmailId y lid) verKey
|
||||
sendVerifyEmail email verKey verUrl
|
||||
defaultLayout $ do
|
||||
setTitle $ string "Confirmation e-mail sent"
|
||||
addBody [$hamlet|
|
||||
%p A confirmation e-mail has been sent to $email$.
|
||||
|]
|
||||
|
||||
getVerifyR :: YesodAuthEmail m
|
||||
=> AuthEmailId m -> String -> GHandler Auth m RepHtml
|
||||
getVerifyR lid key = do
|
||||
realKey <- getVerifyKey lid
|
||||
memail <- getEmail lid
|
||||
case (realKey == Just key, memail) of
|
||||
(True, Just email) -> do
|
||||
muid <- verifyAccount lid
|
||||
case muid of
|
||||
Nothing -> return ()
|
||||
Just uid -> do
|
||||
setCreds False $ Creds "email" email [("verifiedEmail", email)] -- FIXME uid?
|
||||
toMaster <- getRouteToMaster
|
||||
setMessage $ string "Address verified, please set a new password"
|
||||
redirect RedirectTemporary $ toMaster setpass
|
||||
_ -> return ()
|
||||
defaultLayout $ do
|
||||
setTitle $ string "Invalid verification key"
|
||||
addBody [$hamlet|
|
||||
%p I'm sorry, but that was an invalid verification key.
|
||||
|]
|
||||
|
||||
postLoginR :: YesodAuthEmail master => GHandler Auth master ()
|
||||
postLoginR = do
|
||||
(email, pass) <- runFormPost' $ (,)
|
||||
<$> emailInput "email"
|
||||
<*> stringInput "password"
|
||||
y <- getYesod
|
||||
mecreds <- getEmailCreds email
|
||||
maid <-
|
||||
case (mecreds >>= emailCredsAuthId, fmap emailCredsStatus mecreds) of
|
||||
(Just aid, Just True) -> do
|
||||
mrealpass <- getPassword 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 ->
|
||||
setCreds True $ Creds "email" email [("verifiedEmail", email)] -- FIXME aid?
|
||||
Nothing -> do
|
||||
setMessage $ string "Invalid email/password combination"
|
||||
toMaster <- getRouteToMaster
|
||||
redirect RedirectTemporary $ toMaster LoginR
|
||||
|
||||
getPasswordR :: YesodAuthEmail master => GHandler Auth master RepHtml
|
||||
getPasswordR = do
|
||||
toMaster <- getRouteToMaster
|
||||
maid <- maybeAuthId
|
||||
case maid of
|
||||
Just _ -> return ()
|
||||
Nothing -> do
|
||||
setMessage $ string "You must be logged in to set a password"
|
||||
redirect RedirectTemporary $ toMaster login
|
||||
defaultLayout $ do
|
||||
setTitle $ string "Set password"
|
||||
addBody [$hamlet|
|
||||
%h3 Set a new password
|
||||
%form!method=post!action=@toMaster.setpass@
|
||||
%table
|
||||
%tr
|
||||
%th New password
|
||||
%td
|
||||
%input!type=password!name=new
|
||||
%tr
|
||||
%th Confirm
|
||||
%td
|
||||
%input!type=password!name=confirm
|
||||
%tr
|
||||
%td!colspan=2
|
||||
%input!type=submit!value=Submit
|
||||
|]
|
||||
|
||||
postPasswordR :: YesodAuthEmail master => GHandler Auth master ()
|
||||
postPasswordR = do
|
||||
(new, confirm) <- runFormPost' $ (,)
|
||||
<$> stringInput "new"
|
||||
<*> stringInput "confirm"
|
||||
toMaster <- getRouteToMaster
|
||||
when (new /= confirm) $ do
|
||||
setMessage $ string "Passwords did not match, please try again"
|
||||
redirect RedirectTemporary $ toMaster setpass
|
||||
maid <- maybeAuthId
|
||||
aid <- case maid of
|
||||
Nothing -> do
|
||||
setMessage $ string "You must be logged in to set a password"
|
||||
redirect RedirectTemporary $ toMaster login
|
||||
Just aid -> return aid
|
||||
salted <- liftIO $ saltPass new
|
||||
setPassword aid salted
|
||||
setMessage $ string "Password updated"
|
||||
y <- getYesod
|
||||
redirect RedirectTemporary $ defaultDest y
|
||||
|
||||
saltLength :: Int
|
||||
saltLength = 5
|
||||
|
||||
saltPass :: String -> IO String
|
||||
saltPass pass = do
|
||||
stdgen <- newStdGen
|
||||
let salt = take saltLength $ randomRs ('A', 'Z') stdgen
|
||||
return $ saltPass' salt pass
|
||||
|
||||
saltPass' :: String -> String -> String
|
||||
saltPass' salt pass = salt ++ show (md5 $ LU.fromString $ salt ++ pass)
|
||||
|
||||
isValidPass :: String -- ^ cleartext password
|
||||
-> SaltedPass -- ^ salted password
|
||||
-> Bool
|
||||
isValidPass clear salted =
|
||||
let salt = take saltLength salted
|
||||
in salted == saltPass' salt clear
|
||||
51
Yesod/Helpers/Auth2/Facebook.hs
Normal file
51
Yesod/Helpers/Auth2/Facebook.hs
Normal file
@ -0,0 +1,51 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
module Yesod.Helpers.Auth2.Facebook
|
||||
( authFacebook
|
||||
) where
|
||||
|
||||
import Yesod
|
||||
import Yesod.Helpers.Auth2
|
||||
import qualified Web.Authenticate.Facebook as Facebook
|
||||
import Data.Object (fromMapping, lookupScalar)
|
||||
import Data.Maybe (fromMaybe)
|
||||
|
||||
authFacebook :: YesodAuth m
|
||||
=> String -- ^ Application ID
|
||||
-> String -- ^ Application secret
|
||||
-> [String] -- ^ Requested permissions
|
||||
-> AuthPlugin m
|
||||
authFacebook cid secret perms =
|
||||
AuthPlugin "facebook" dispatch login
|
||||
where
|
||||
url = PluginR "facebook" []
|
||||
dispatch "GET" [] = do
|
||||
render <- getUrlRender
|
||||
tm <- getRouteToMaster
|
||||
let fb = Facebook.Facebook cid secret $ render $ tm url
|
||||
code <- runFormGet' $ stringInput "code"
|
||||
at <- liftIO $ Facebook.getAccessToken fb code
|
||||
let Facebook.AccessToken at' = at
|
||||
so <- liftIO $ Facebook.getGraphData at "me"
|
||||
let c = fromMaybe (error "Invalid response from Facebook") $ do
|
||||
m <- fromMapping so
|
||||
id' <- lookupScalar "id" m
|
||||
let name = lookupScalar "name" m
|
||||
let email = lookupScalar "email" m
|
||||
let id'' = "http://graph.facebook.com/" ++ id'
|
||||
return
|
||||
$ Creds "facebook" id''
|
||||
$ maybe id (\x -> (:) ("verifiedEmail", x)) email
|
||||
$ maybe id (\x -> (:) ("displayName ", x)) name
|
||||
[ ("accessToken", at')
|
||||
]
|
||||
setCreds True c
|
||||
dispatch _ _ = notFound
|
||||
login = do
|
||||
tm <- liftHandler getRouteToMaster
|
||||
render <- liftHandler getUrlRender
|
||||
let fb = Facebook.Facebook cid secret $ render $ tm url
|
||||
let furl = Facebook.getForwardUrl fb $ perms
|
||||
addBody [$hamlet|
|
||||
%p
|
||||
%a!href=$furl$ Login with Facebook
|
||||
|]
|
||||
60
Yesod/Helpers/Auth2/OpenId.hs
Normal file
60
Yesod/Helpers/Auth2/OpenId.hs
Normal file
@ -0,0 +1,60 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
module Yesod.Helpers.Auth2.OpenId
|
||||
( authOpenId
|
||||
) where
|
||||
|
||||
import Yesod
|
||||
import Yesod.Helpers.Auth2
|
||||
import qualified Web.Authenticate.OpenId as OpenId
|
||||
import Control.Monad.Attempt
|
||||
|
||||
authOpenId :: YesodAuth m => AuthPlugin m
|
||||
authOpenId =
|
||||
AuthPlugin "openid" dispatch login
|
||||
where
|
||||
forward = PluginR "openid" ["forward"]
|
||||
complete = PluginR "openid" ["complete"]
|
||||
name = "openid_identifier"
|
||||
login = do
|
||||
tm <- liftHandler getRouteToMaster
|
||||
addStyle [$cassius|
|
||||
#openid
|
||||
background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%;
|
||||
padding-left: 18px;
|
||||
|]
|
||||
addBody [$hamlet|
|
||||
%form!method=post!action=@tm.forward@
|
||||
%label!for=openid OpenID: $
|
||||
%input#openid!type=text!name=$name$
|
||||
%input!type=submit!value="Login via OpenID"
|
||||
|]
|
||||
dispatch "POST" ["forward"] = do
|
||||
(roid, _, _) <- runFormPost $ stringInput name
|
||||
case roid of
|
||||
FormSuccess oid -> do
|
||||
render <- getUrlRender
|
||||
toMaster <- getRouteToMaster
|
||||
let complete' = render $ toMaster complete
|
||||
res <- runAttemptT $ OpenId.getForwardUrl oid complete'
|
||||
attempt
|
||||
(\err -> do
|
||||
setMessage $ string $ show err
|
||||
redirect RedirectTemporary $ toMaster LoginR)
|
||||
(redirectString RedirectTemporary)
|
||||
res
|
||||
_ -> do
|
||||
toMaster <- getRouteToMaster
|
||||
setMessage $ string "No OpenID identifier found"
|
||||
redirect RedirectTemporary $ toMaster LoginR
|
||||
dispatch "GET" ["complete"] = do
|
||||
rr <- getRequest
|
||||
let gets' = reqGetParams rr
|
||||
res <- runAttemptT $ OpenId.authenticate gets'
|
||||
toMaster <- getRouteToMaster
|
||||
let onFailure err = do
|
||||
setMessage $ string $ show err
|
||||
redirect RedirectTemporary $ toMaster LoginR
|
||||
let onSuccess (OpenId.Identifier ident) =
|
||||
setCreds True $ Creds "openid" ident []
|
||||
attempt onFailure onSuccess res
|
||||
dispatch _ _ = notFound
|
||||
46
Yesod/Helpers/Auth2/Rpxnow.hs
Normal file
46
Yesod/Helpers/Auth2/Rpxnow.hs
Normal file
@ -0,0 +1,46 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
module Yesod.Helpers.Auth2.Rpxnow
|
||||
( authRpxnow
|
||||
) where
|
||||
|
||||
import Yesod
|
||||
import Yesod.Helpers.Auth2
|
||||
import qualified Web.Authenticate.Rpxnow as Rpxnow
|
||||
import Control.Monad (mplus)
|
||||
|
||||
authRpxnow :: YesodAuth m
|
||||
=> String -- ^ app name
|
||||
-> String -- ^ key
|
||||
-> AuthPlugin m
|
||||
authRpxnow app apiKey =
|
||||
AuthPlugin "rpxnow" dispatch login
|
||||
where
|
||||
login = do
|
||||
tm <- liftHandler getRouteToMaster
|
||||
let url = {- FIXME urlEncode $ -} tm $ PluginR "rpxnow" []
|
||||
addBody [$hamlet|
|
||||
%iframe!src="http://$app$.rpxnow.com/openid/embed?token_url=@url@"!scrolling=no!frameBorder=no!allowtransparency=true!style="width:400px;height:240px"
|
||||
|]
|
||||
dispatch _ [] = do
|
||||
token1 <- lookupGetParam "token"
|
||||
token2 <- lookupPostParam "token"
|
||||
let token = case token1 `mplus` token2 of
|
||||
Nothing -> invalidArgs ["token: Value not supplied"]
|
||||
Just x -> x
|
||||
Rpxnow.Identifier ident extra <- liftIO $ Rpxnow.authenticate apiKey token
|
||||
let creds =
|
||||
Creds "rpxnow" ident
|
||||
$ maybe id (\x -> (:) ("verifiedEmail", x))
|
||||
(lookup "verifiedEmail" extra)
|
||||
$ maybe id (\x -> (:) ("displayName", x))
|
||||
(getDisplayName extra)
|
||||
[]
|
||||
setCreds True creds
|
||||
dispatch _ _ = notFound
|
||||
|
||||
-- | Get some form of a display name.
|
||||
getDisplayName :: [(String, String)] -> Maybe String
|
||||
getDisplayName extra =
|
||||
foldr (\x -> mplus (lookup x extra)) Nothing choices
|
||||
where
|
||||
choices = ["verifiedEmail", "email", "displayName", "preferredUsername"]
|
||||
135
auth2.hs
Normal file
135
auth2.hs
Normal file
@ -0,0 +1,135 @@
|
||||
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
import Yesod
|
||||
import Yesod.Mail
|
||||
|
||||
import Yesod.Helpers.Auth2
|
||||
import Yesod.Helpers.Auth2.OpenId
|
||||
import Yesod.Helpers.Auth2.Rpxnow
|
||||
import Yesod.Helpers.Auth2.Facebook
|
||||
import Yesod.Helpers.Auth2.Email
|
||||
|
||||
import Control.Monad (join)
|
||||
import Database.Persist.Sqlite
|
||||
import Safe (readMay)
|
||||
|
||||
mkPersist [$persist|
|
||||
Email
|
||||
email String
|
||||
status Bool update
|
||||
verkey String null update
|
||||
password String null update
|
||||
UniqueEmail email
|
||||
|]
|
||||
|
||||
data A2 = A2 { connPool :: ConnectionPool }
|
||||
mkYesod "A2" [$parseRoutes|
|
||||
/auth AuthR Auth getAuth
|
||||
|]
|
||||
instance Yesod A2 where approot _ = "http://localhost:3000"
|
||||
instance YesodAuth A2 where
|
||||
type AuthId A2 = String
|
||||
defaultDest _ = AuthR CheckR
|
||||
getAuthId = return . Just . credsIdent
|
||||
showAuthId = const id
|
||||
readAuthId = const Just
|
||||
authPlugins =
|
||||
[ authDummy
|
||||
, authOpenId
|
||||
, authRpxnow "yesod-test" "c8043882f14387d7ad8dfc99a1a8dab2e028f690"
|
||||
, authFacebook
|
||||
"d790dfc0203e31c0209ed32f90782c31"
|
||||
"a7685e10c8977f5435e599aaf1d232eb"
|
||||
[]
|
||||
, authEmail
|
||||
]
|
||||
|
||||
main :: IO ()
|
||||
main = withConnectionPool $ \p -> do
|
||||
flip runConnectionPool p $ runMigration $ migrate (undefined :: Email)
|
||||
basicHandler 3000 $ A2 p
|
||||
|
||||
instance YesodAuthEmail A2 where
|
||||
type AuthEmailId A2 = EmailId
|
||||
showAuthEmailId _ = show
|
||||
readAuthEmailId _ = readMay
|
||||
|
||||
addUnverified email verkey = runDB $ insert $ Email email False (Just verkey) Nothing
|
||||
sendVerifyEmail email verkey verurl = do
|
||||
render <- getUrlRenderParams
|
||||
tm <- getRouteToMaster
|
||||
let lbs = renderHamlet render [$hamlet|
|
||||
%p
|
||||
%a!href=$verurl$ Verify your email address.
|
||||
|]
|
||||
liftIO $ renderSendMail Mail
|
||||
{ mailHeaders =
|
||||
[ ("To", email)
|
||||
, ("From", "reply@orangeroster.com")
|
||||
, ("Subject", "OrangeRoster: Verify your email address")
|
||||
]
|
||||
, mailPlain = verurl
|
||||
, mailParts =
|
||||
[ Part
|
||||
{ partType = "text/html; charset=utf-8"
|
||||
, partEncoding = None
|
||||
, partDisposition = Inline
|
||||
, partContent = lbs
|
||||
}
|
||||
]
|
||||
}
|
||||
getVerifyKey emailid = runDB $ do
|
||||
x <- get $ fromIntegral emailid
|
||||
return $ maybe Nothing emailVerkey x
|
||||
setVerifyKey emailid verkey = runDB $
|
||||
update (fromIntegral emailid) [EmailVerkey $ Just verkey]
|
||||
verifyAccount emailid' = runDB $ do
|
||||
{- FIXME
|
||||
let emailid = fromIntegral emailid'
|
||||
x <- get emailid
|
||||
uid <-
|
||||
case x of
|
||||
Nothing -> return Nothing
|
||||
Just (Email (Just uid) _ _) -> return $ Just uid
|
||||
Just (Email Nothing email _) -> do
|
||||
update emailid [EmailStatus True]
|
||||
return $ Just email
|
||||
update emailid [EmailVerkey Nothing]
|
||||
return uid
|
||||
-}
|
||||
return Nothing
|
||||
getPassword _ = return Nothing -- FIXME runDB . fmap (join . fmap emailPassword) . get
|
||||
setPassword emailid password = runDB $ do
|
||||
{- FIXME
|
||||
_x <- get emailid
|
||||
case x of
|
||||
Just (Email (Just uid) _ _) -> do
|
||||
update uid [EmailPassword $ Just password]
|
||||
update emailid [EmailVerkey Nothing]
|
||||
_ -> return ()
|
||||
-}
|
||||
return ()
|
||||
getEmailCreds email = runDB $ do
|
||||
x <- getBy $ UniqueEmail email
|
||||
case x of
|
||||
Nothing -> return Nothing
|
||||
Just (eid, e) ->
|
||||
return $ Just EmailCreds
|
||||
{ emailCredsId = fromIntegral eid
|
||||
, emailCredsAuthId = Just $ emailEmail e
|
||||
, emailCredsStatus = emailStatus e
|
||||
, emailCredsVerkey = emailVerkey e
|
||||
}
|
||||
getEmail emailid = runDB $ do
|
||||
x <- get $ fromIntegral emailid
|
||||
return $ fmap emailEmail x
|
||||
|
||||
instance YesodPersist A2 where
|
||||
type YesodDB A2 = SqlPersist
|
||||
runDB db = fmap connPool getYesod >>= runConnectionPool db
|
||||
|
||||
withConnectionPool :: MonadCatchIO m => (ConnectionPool -> m a) -> m a
|
||||
withConnectionPool = withSqlitePool "auth2.db3" 10
|
||||
|
||||
runConnectionPool :: MonadCatchIO m => SqlPersist m a -> ConnectionPool -> m a
|
||||
runConnectionPool = runSqlPool
|
||||
35
yesod-auth.cabal
Normal file
35
yesod-auth.cabal
Normal file
@ -0,0 +1,35 @@
|
||||
name: yesod-auth
|
||||
version: 0.0.0
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
maintainer: Michael Snoyman <michael@snoyman.com>
|
||||
synopsis: Authentication for Yesod.
|
||||
category: Web
|
||||
stability: Stable
|
||||
cabal-version: >= 1.6
|
||||
build-type: Simple
|
||||
homepage: http://docs.yesodweb.com/
|
||||
|
||||
library
|
||||
build-depends: base >= 4 && < 5
|
||||
, authenticate >= 0.6.4 && < 0.7
|
||||
, bytestring >= 0.9.1.4 && < 0.10
|
||||
, yesod >= 0.5.1 && < 0.6
|
||||
, wai >= 0.2 && < 0.3
|
||||
, template-haskell
|
||||
, pureMD5 >= 1.1 && < 1.2
|
||||
, random >= 1.0 && < 1.1
|
||||
, data-object >= 0.3.1.3 && < 0.4
|
||||
, control-monad-attempt >= 0.3.0 && < 0.4
|
||||
, utf8-string >= 0.3.4 && < 0.4
|
||||
exposed-modules: Yesod.Helpers.Auth2
|
||||
Yesod.Helpers.Auth2.Email
|
||||
Yesod.Helpers.Auth2.Facebook
|
||||
Yesod.Helpers.Auth2.OpenId
|
||||
Yesod.Helpers.Auth2.Rpxnow
|
||||
ghc-options: -Wall
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: git://github.com/snoyberg/yesod.git
|
||||
Loading…
Reference in New Issue
Block a user