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

yesod-core 0.8

Browse Source
This commit is contained in:
Michael Snoyman 2011-04-07 23:16:49 +03:00
parent ef635dc07d
commit 2b957655c6
9 changed files with 119 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
Yesod/Helpers/Auth.hs
View File

@ -4,6 +4,7 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Yesod.Helpers.Auth module Yesod.Helpers.Auth
( -- * Subsite ( -- * Subsite
Auth Auth
@ -35,17 +36,22 @@ import qualified Data.ByteString.Char8 as S8
import qualified Network.Wai as W import qualified Network.Wai as W
import Text.Hamlet (hamlet) import Text.Hamlet (hamlet)
import Data.Text.Lazy (pack) import Data.Text.Lazy (pack)
import Data.JSON.Types (Value (..), Atom (AtomBoolean))
import qualified Data.Map as Map import qualified Data.Map as Map
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import Data.Aeson
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Monoid (mconcat)
data Auth = Auth data Auth = Auth
type Method = String type Method = Text
type Piece = String type Piece = Text
data AuthPlugin m = AuthPlugin data AuthPlugin m = AuthPlugin
{ apName :: String { apName :: Text
, apDispatch :: Method -> [Piece] -> GHandler Auth m () , apDispatch :: Method -> [Piece] -> GHandler Auth m ()
, apLogin :: forall s. (Route Auth -> Route m) -> GWidget s m () , apLogin :: forall s. (Route Auth -> Route m) -> GWidget s m ()
} }
@ -55,9 +61,9 @@ getAuth = const Auth
-- | User credentials -- | User credentials
data Creds m = Creds data Creds m = Creds
{ credsPlugin :: String -- ^ How the user was authenticated { credsPlugin :: Text -- ^ How the user was authenticated
, credsIdent :: String -- ^ Identifier. Exact meaning depends on plugin. , credsIdent :: Text -- ^ Identifier. Exact meaning depends on plugin.
, credsExtra :: [(String, String)] , credsExtra :: [(Text, Text)]
} }
class Yesod m => YesodAuth m where class Yesod m => YesodAuth m where
@ -73,8 +79,8 @@ class Yesod m => YesodAuth m where
getAuthId :: Creds m -> GHandler s m (Maybe (AuthId m)) getAuthId :: Creds m -> GHandler s m (Maybe (AuthId m))
showAuthId :: m -> AuthId m -> String showAuthId :: m -> AuthId m -> Text
readAuthId :: m -> String -> Maybe (AuthId m) readAuthId :: m -> Text -> Maybe (AuthId m)
authPlugins :: [AuthPlugin m] authPlugins :: [AuthPlugin m]
@ -104,8 +110,9 @@ class Yesod m => YesodAuth m where
messageEnterEmail _ = string "Enter your e-mail address below, and a confirmation e-mail will be sent to you." messageEnterEmail _ = string "Enter your e-mail address below, and a confirmation e-mail will be sent to you."
messageConfirmationEmailSentTitle :: m -> Html messageConfirmationEmailSentTitle :: m -> Html
messageConfirmationEmailSentTitle _ = string "Confirmation e-mail sent" messageConfirmationEmailSentTitle _ = string "Confirmation e-mail sent"
messageConfirmationEmailSent :: m -> String -> Html messageConfirmationEmailSent :: m -> Text -> Html
messageConfirmationEmailSent _ email = string $ "A confirmation e-mail has been sent to " ++ email ++ "." messageConfirmationEmailSent _ email = toHtml $ mconcat
["A confirmation e-mail has been sent to ", email, "."]
messageAddressVerified :: m -> Html messageAddressVerified :: m -> Html
messageAddressVerified _ = string "Address verified, please set a new password" messageAddressVerified _ = string "Address verified, please set a new password"
messageInvalidKeyTitle :: m -> Html messageInvalidKeyTitle :: m -> Html
@ -132,10 +139,12 @@ class Yesod m => YesodAuth m where
messageFacebook :: m -> Html messageFacebook :: m -> Html
messageFacebook _ = string "Login with Facebook" messageFacebook _ = string "Login with Facebook"
type Texts = [Text]
mkYesodSub "Auth" mkYesodSub "Auth"
[ ClassP ''YesodAuth [VarT $ mkName "master"] [ ClassP ''YesodAuth [VarT $ mkName "master"]
] ]
#define STRINGS *Strings #define STRINGS *Texts
#if GHC7 #if GHC7
[parseRoutes| [parseRoutes|
#else #else
@ -144,10 +153,10 @@ mkYesodSub "Auth"
/check CheckR GET /check CheckR GET
/login LoginR GET /login LoginR GET
/logout LogoutR GET POST /logout LogoutR GET POST
/page/#String/STRINGS PluginR /page/#Text/STRINGS PluginR
|] |]
credsKey :: String credsKey :: Text
credsKey = "_ID" credsKey = "_ID"
-- | FIXME: won't show up till redirect -- | FIXME: won't show up till redirect
@ -202,10 +211,8 @@ $nothing
<p>Not logged in. <p>Not logged in.
|] |]
json creds = json creds =
ValueObject $ Map.fromList Object $ Map.fromList
[ (pack "logged_in" [ (T.pack "logged_in", Bool $ maybe False (const True) creds)
, ValueAtom $ AtomBoolean
$ maybe False (const True) creds)
] ]
getLoginR :: YesodAuth m => GHandler Auth m RepHtml getLoginR :: YesodAuth m => GHandler Auth m RepHtml
@ -220,10 +227,10 @@ postLogoutR = do
deleteSession credsKey deleteSession credsKey
redirectUltDest RedirectTemporary $ logoutDest y redirectUltDest RedirectTemporary $ logoutDest y
handlePluginR :: YesodAuth m => String -> [String] -> GHandler Auth m () handlePluginR :: YesodAuth m => Text -> [Text] -> GHandler Auth m ()
handlePluginR plugin pieces = do handlePluginR plugin pieces = do
env <- waiRequest env <- waiRequest
let method = S8.unpack $ W.requestMethod env let method = decodeUtf8With lenientDecode $ W.requestMethod env
case filter (\x -> apName x == plugin) authPlugins of case filter (\x -> apName x == plugin) authPlugins of
[] -> notFound [] -> notFound
ap:_ -> apDispatch ap method pieces ap:_ -> apDispatch ap method pieces

1
Yesod/Helpers/Auth/Dummy.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Provides a dummy authentication module that simply lets a user specify -- | Provides a dummy authentication module that simply lets a user specify
-- his/her identifier. This is not intended for real world use, just for -- his/her identifier. This is not intended for real world use, just for
-- testing. -- testing.

34
Yesod/Helpers/Auth/Email.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE QuasiQuotes, TypeFamilies #-} {-# LANGUAGE QuasiQuotes, TypeFamilies #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Yesod.Helpers.Auth.Email module Yesod.Helpers.Auth.Email
( -- * Plugin ( -- * Plugin
authEmail authEmail
@ -19,7 +20,9 @@ import Control.Monad (when)
import Control.Applicative ((<$>), (<*>)) import Control.Applicative ((<$>), (<*>))
import Data.Digest.Pure.MD5 import Data.Digest.Pure.MD5
import qualified Data.Text.Lazy as T import qualified Data.Text.Lazy as T
import qualified Data.Text as TS
import Data.Text.Lazy.Encoding (encodeUtf8) import Data.Text.Lazy.Encoding (encodeUtf8)
import Data.Text (Text)
import Yesod.Form import Yesod.Form
import Yesod.Handler import Yesod.Handler
@ -35,13 +38,13 @@ loginR = PluginR "email" ["login"]
registerR = PluginR "email" ["register"] registerR = PluginR "email" ["register"]
setpassR = PluginR "email" ["set-password"] setpassR = PluginR "email" ["set-password"]
verify :: String -> String -> AuthRoute -- FIXME verify :: Text -> Text -> AuthRoute -- FIXME
verify eid verkey = PluginR "email" ["verify", eid, verkey] verify eid verkey = PluginR "email" ["verify", eid, verkey]
type Email = String type Email = Text
type VerKey = String type VerKey = Text
type VerUrl = String type VerUrl = Text
type SaltedPass = String type SaltedPass = Text
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.
@ -55,8 +58,8 @@ data EmailCreds m = EmailCreds
class YesodAuth m => YesodAuthEmail m where class YesodAuth m => YesodAuthEmail m where
type AuthEmailId m type AuthEmailId m
showAuthEmailId :: m -> AuthEmailId m -> String showAuthEmailId :: m -> AuthEmailId m -> Text
readAuthEmailId :: m -> String -> Maybe (AuthEmailId m) readAuthEmailId :: m -> Text -> Maybe (AuthEmailId m)
addUnverified :: Email -> VerKey -> GHandler Auth m (AuthEmailId m) addUnverified :: Email -> VerKey -> GHandler Auth m (AuthEmailId m)
sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler Auth m () sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler Auth m ()
@ -69,10 +72,10 @@ class YesodAuth m => YesodAuthEmail m where
getEmail :: AuthEmailId m -> GHandler Auth m (Maybe Email) getEmail :: AuthEmailId m -> GHandler Auth m (Maybe Email)
-- | Generate a random alphanumeric string. -- | Generate a random alphanumeric string.
randomKey :: m -> IO String randomKey :: m -> IO Text
randomKey _ = do randomKey _ = do
stdgen <- newStdGen stdgen <- newStdGen
return $ fst $ randomString 10 stdgen return $ TS.pack $ fst $ randomString 10 stdgen
authEmail :: YesodAuthEmail m => AuthPlugin m authEmail :: YesodAuthEmail m => AuthPlugin m
authEmail = authEmail =
@ -162,7 +165,7 @@ postRegisterR = do
|] |]
getVerifyR :: YesodAuthEmail m getVerifyR :: YesodAuthEmail m
=> AuthEmailId m -> String -> GHandler Auth m RepHtml => AuthEmailId m -> Text -> GHandler Auth m RepHtml
getVerifyR lid key = do getVerifyR lid key = do
realKey <- getVerifyKey lid realKey <- getVerifyKey lid
memail <- getEmail lid memail <- getEmail lid
@ -274,11 +277,11 @@ saltLength :: Int
saltLength = 5 saltLength = 5
-- | Salt a password with a randomly generated salt. -- | Salt a password with a randomly generated salt.
saltPass :: String -> IO String saltPass :: Text -> IO Text
saltPass pass = do saltPass pass = do
stdgen <- newStdGen stdgen <- newStdGen
let salt = take saltLength $ randomRs ('A', 'Z') stdgen let salt = take saltLength $ randomRs ('A', 'Z') stdgen
return $ saltPass' salt pass return $ TS.pack $ saltPass' salt $ TS.unpack pass
saltPass' :: String -> String -> String saltPass' :: String -> String -> String
saltPass' salt pass = saltPass' salt pass =
@ -286,9 +289,12 @@ saltPass' salt pass =
where where
fromString = encodeUtf8 . T.pack fromString = encodeUtf8 . T.pack
isValidPass :: String -- ^ cleartext password isValidPass :: Text -- ^ cleartext password
-> SaltedPass -- ^ salted password -> SaltedPass -- ^ salted password
-> Bool -> Bool
isValidPass clear salted = isValidPass clear' salted' =
let salt = take saltLength salted let salt = take saltLength salted
in salted == saltPass' salt clear in salted == saltPass' salt clear
where
clear = TS.unpack clear'
salted = TS.unpack salted'

42
Yesod/Helpers/Auth/Facebook.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Yesod.Helpers.Auth.Facebook module Yesod.Helpers.Auth.Facebook
( authFacebook ( authFacebook
, facebookUrl , facebookUrl
@ -7,7 +8,8 @@ module Yesod.Helpers.Auth.Facebook
import Yesod.Helpers.Auth import Yesod.Helpers.Auth
import qualified Web.Authenticate.Facebook as Facebook import qualified Web.Authenticate.Facebook as Facebook
import Data.Object (fromMapping, lookupScalar) import Data.Aeson
import Data.Aeson.Types (parseMaybe)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Yesod.Form import Yesod.Form
@ -17,14 +19,17 @@ import Text.Hamlet (hamlet)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import Data.Text (Text)
import Control.Monad (mzero)
import Data.Monoid (mappend)
facebookUrl :: AuthRoute facebookUrl :: AuthRoute
facebookUrl = PluginR "facebook" ["forward"] facebookUrl = PluginR "facebook" ["forward"]
authFacebook :: YesodAuth m authFacebook :: YesodAuth m
=> String -- ^ Application ID => Text -- ^ Application ID
-> String -- ^ Application secret -> Text -- ^ Application secret
-> [String] -- ^ Requested permissions -> [Text] -- ^ Requested permissions
-> AuthPlugin m -> AuthPlugin m
authFacebook cid secret perms = authFacebook cid secret perms =
AuthPlugin "facebook" dispatch login AuthPlugin "facebook" dispatch login
@ -34,7 +39,7 @@ authFacebook cid secret perms =
tm <- getRouteToMaster tm <- getRouteToMaster
render <- getUrlRender render <- getUrlRender
let fb = Facebook.Facebook cid secret $ render $ tm url let fb = Facebook.Facebook cid secret $ render $ tm url
redirectString RedirectTemporary $ S8.pack $ Facebook.getForwardUrl fb perms redirectString RedirectTemporary $ Facebook.getForwardUrl fb perms
dispatch "GET" [] = do dispatch "GET" [] = do
render <- getUrlRender render <- getUrlRender
tm <- getRouteToMaster tm <- getRouteToMaster
@ -43,18 +48,8 @@ authFacebook cid secret perms =
at <- liftIO $ Facebook.getAccessToken fb code at <- liftIO $ Facebook.getAccessToken fb code
let Facebook.AccessToken at' = at let Facebook.AccessToken at' = at
so <- liftIO $ Facebook.getGraphData at "me" so <- liftIO $ Facebook.getGraphData at "me"
let c = fromMaybe (error "Invalid response from Facebook") $ do let c = fromMaybe (error "Invalid response from Facebook")
m <- fromMapping so $ parseMaybe (parseCreds at') $ either error id 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 setCreds True c
dispatch _ _ = notFound dispatch _ _ = notFound
login tm = do login tm = do
@ -71,3 +66,16 @@ authFacebook cid secret perms =
<p> <p>
<a href="#{furl}">#{messageFacebook y} <a href="#{furl}">#{messageFacebook y}
|] |]
parseCreds at' (Object m) = do
id' <- m .: "id"
let id'' = "http://graph.facebook.com/" `mappend` id'
name <- m .: "name"
email <- m .: "email"
return
$ Creds "facebook" id''
$ maybe id (\x -> (:) ("verifiedEmail", x)) email
$ maybe id (\x -> (:) ("displayName ", x)) name
[ ("accessToken", at')
]
parseCreds _ _ = mzero

13
Yesod/Helpers/Auth/HashDB.hs
View File

@ -4,6 +4,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- | -- |
-- Module : Yesod.Helpers.Auth.HashDB -- Module : Yesod.Helpers.Auth.HashDB
@ -72,8 +73,8 @@ import Text.Hamlet (hamlet)
import Control.Applicative ((<$>), (<*>)) import Control.Applicative ((<$>), (<*>))
import Data.ByteString.Lazy.Char8 (pack) import Data.ByteString.Lazy.Char8 (pack)
import Data.Digest.Pure.SHA (sha1, showDigest) import Data.Digest.Pure.SHA (sha1, showDigest)
import Database.Persist.TH (share2) import Database.Persist.TH (share2, mkMigrate, persist, mkPersist)
import Database.Persist.GenericSql (mkMigrate) import Data.Text (Text, unpack)
-- | Computer the sha1 of a string and return it as a string -- | Computer the sha1 of a string and return it as a string
sha1String :: String -> String sha1String :: String -> String
@ -87,8 +88,8 @@ share2 mkPersist (mkMigrate "migrateUsers")
[$persist| [$persist|
#endif #endif
User User
username String Eq username Text Eq
password String password Text
UniqueUser username UniqueUser username
|] |]
@ -96,14 +97,14 @@ User
-- database values -- database values
validateUser :: (YesodPersist y, validateUser :: (YesodPersist y,
PersistBackend (YesodDB y (GGHandler sub y IO))) PersistBackend (YesodDB y (GGHandler sub y IO)))
=> (String, String) => (Text, Text)
-> GHandler sub y Bool -> GHandler sub y Bool
validateUser (user,password) = runDB (getBy $ UniqueUser user) >>= \dbUser -> validateUser (user,password) = runDB (getBy $ UniqueUser user) >>= \dbUser ->
case dbUser of case dbUser of
-- user not found -- user not found
Nothing -> return False Nothing -> return False
-- validate password -- validate password
Just (_, sqlUser) -> return $ sha1String password == userPassword sqlUser Just (_, sqlUser) -> return $ sha1String (unpack password) == unpack (userPassword sqlUser)
login :: AuthRoute login :: AuthRoute
login = PluginR "hashdb" ["login"] login = PluginR "hashdb" ["login"]

21
Yesod/Helpers/Auth/OAuth.hs
View File

@ -15,17 +15,20 @@ import Web.Authenticate.OAuth
import Data.Maybe import Data.Maybe
import Data.String import Data.String
import Network.HTTP.Enumerator import Network.HTTP.Enumerator
import Data.ByteString.Char8 (unpack, pack) import Data.ByteString.Char8 (pack)
import Control.Arrow ((***)) import Control.Arrow ((***))
import Control.Monad import Control.Monad
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import Data.Text (Text, unpack)
import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
oauthUrl :: String -> AuthRoute oauthUrl :: Text -> AuthRoute
oauthUrl name = PluginR name ["forward"] oauthUrl name = PluginR name ["forward"]
authOAuth :: YesodAuth m => authOAuth :: YesodAuth m =>
String -- ^ Service Name Text -- ^ Service Name
-> String -- ^ OAuth Parameter Name to use for identify -> String -- ^ OAuth Parameter Name to use for identify
-> String -- ^ Request URL -> String -- ^ Request URL
-> String -- ^ Access Token URL -> String -- ^ Access Token URL
@ -36,7 +39,7 @@ authOAuth :: YesodAuth m =>
authOAuth name ident reqUrl accUrl authUrl key sec = AuthPlugin name dispatch login authOAuth name ident reqUrl accUrl authUrl key sec = AuthPlugin name dispatch login
where where
url = PluginR name [] url = PluginR name []
oauth = OAuth { oauthServerName = name, oauthRequestUri = reqUrl oauth = OAuth { oauthServerName = unpack name, oauthRequestUri = reqUrl
, oauthAccessTokenUri = accUrl, oauthAuthorizeUri = authUrl , oauthAccessTokenUri = accUrl, oauthAuthorizeUri = authUrl
, oauthSignatureMethod = HMACSHA1 , oauthSignatureMethod = HMACSHA1
, oauthConsumerKey = fromString key, oauthConsumerSecret = fromString sec , oauthConsumerKey = fromString key, oauthConsumerSecret = fromString sec
@ -45,7 +48,7 @@ authOAuth name ident reqUrl accUrl authUrl key sec = AuthPlugin name dispatch lo
dispatch "GET" ["forward"] = do dispatch "GET" ["forward"] = do
render <- getUrlRender render <- getUrlRender
tm <- getRouteToMaster tm <- getRouteToMaster
let oauth' = oauth { oauthCallback = Just $ fromString $ render $ tm url } let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url }
tok <- liftIO $ getTemporaryCredential oauth' tok <- liftIO $ getTemporaryCredential oauth'
redirectString RedirectTemporary (fromString $ authorizeUrl oauth' tok) redirectString RedirectTemporary (fromString $ authorizeUrl oauth' tok)
dispatch "GET" [] = do dispatch "GET" [] = do
@ -54,11 +57,11 @@ authOAuth name ident reqUrl accUrl authUrl key sec = AuthPlugin name dispatch lo
let callback = render $ tm url let callback = render $ tm url
verifier <- runFormGet' $ stringInput "oauth_verifier" verifier <- runFormGet' $ stringInput "oauth_verifier"
oaTok <- runFormGet' $ stringInput "oauth_token" oaTok <- runFormGet' $ stringInput "oauth_token"
let reqTok = Credential [ ("oauth_verifier", pack verifier), ("oauth_token", pack oaTok) let reqTok = Credential [ ("oauth_verifier", encodeUtf8 verifier), ("oauth_token", encodeUtf8 oaTok)
] ]
accTok <- liftIO $ getAccessToken oauth reqTok accTok <- liftIO $ getAccessToken oauth reqTok
let crId = unpack $ fromJust $ lookup (pack ident) $ unCredential accTok let crId = decodeUtf8With lenientDecode $ fromJust $ lookup (pack ident) $ unCredential accTok
creds = Creds name crId $ map (unpack *** unpack) $ unCredential accTok creds = Creds name crId $ map (bsToText *** bsToText ) $ unCredential accTok
setCreds True creds setCreds True creds
dispatch _ _ = notFound dispatch _ _ = notFound
login tm = do login tm = do
@ -85,3 +88,5 @@ authTwitter = authOAuth "twitter"
twitterUrl :: AuthRoute twitterUrl :: AuthRoute
twitterUrl = oauthUrl "twitter" twitterUrl = oauthUrl "twitter"
bsToText = decodeUtf8With lenientDecode

6
Yesod/Helpers/Auth/OpenId.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Yesod.Helpers.Auth.OpenId module Yesod.Helpers.Auth.OpenId
( authOpenId ( authOpenId
, forwardUrl , forwardUrl
@ -18,6 +19,7 @@ import Text.Cassius (cassius)
import Text.Blaze (string) import Text.Blaze (string)
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
import Data.Text (Text)
forwardUrl :: AuthRoute forwardUrl :: AuthRoute
forwardUrl = PluginR "openid" ["forward"] forwardUrl = PluginR "openid" ["forward"]
@ -65,7 +67,7 @@ authOpenId =
setMessage $ string $ show err setMessage $ string $ show err
redirect RedirectTemporary $ toMaster LoginR redirect RedirectTemporary $ toMaster LoginR
) )
(redirectString RedirectTemporary . S8.pack) (redirectString RedirectTemporary)
res res
_ -> do _ -> do
toMaster <- getRouteToMaster toMaster <- getRouteToMaster
@ -81,7 +83,7 @@ authOpenId =
completeHelper posts completeHelper posts
dispatch _ _ = notFound dispatch _ _ = notFound
completeHelper :: YesodAuth m => [(String, String)] -> GHandler Auth m () completeHelper :: YesodAuth m => [(Text, Text)] -> GHandler Auth m ()
completeHelper gets' = do completeHelper gets' = do
res <- runAttemptT $ OpenId.authenticate gets' res <- runAttemptT $ OpenId.authenticate gets'
toMaster <- getRouteToMaster toMaster <- getRouteToMaster

15
Yesod/Helpers/Auth/Rpxnow.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Yesod.Helpers.Auth.Rpxnow module Yesod.Helpers.Auth.Rpxnow
( authRpxnow ( authRpxnow
) where ) where
@ -13,6 +14,8 @@ import Yesod.Widget
import Yesod.Request import Yesod.Request
import Text.Hamlet (hamlet) import Text.Hamlet (hamlet)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Data.Text (Text, pack, unpack)
import Control.Arrow ((***))
authRpxnow :: YesodAuth m authRpxnow :: YesodAuth m
=> String -- ^ app name => String -- ^ app name
@ -32,18 +35,18 @@ authRpxnow app apiKey =
<iframe src="http://#{app}.rpxnow.com/openid/embed?token_url=@{url}" scrolling="no" frameBorder="no" allowtransparency="true" style="width:400px;height:240px"> <iframe src="http://#{app}.rpxnow.com/openid/embed?token_url=@{url}" scrolling="no" frameBorder="no" allowtransparency="true" style="width:400px;height:240px">
|] |]
dispatch _ [] = do dispatch _ [] = do
token1 <- lookupGetParam "token" token1 <- lookupGetParams "token"
token2 <- lookupPostParam "token" token2 <- lookupPostParams "token"
let token = case token1 `mplus` token2 of token <- case token1 ++ token2 of
Nothing -> invalidArgs ["token: Value not supplied"] [] -> invalidArgs ["token: Value not supplied"]
Just x -> x x:_ -> return $ unpack x
Rpxnow.Identifier ident extra <- liftIO $ Rpxnow.authenticate apiKey token Rpxnow.Identifier ident extra <- liftIO $ Rpxnow.authenticate apiKey token
let creds = let creds =
Creds "rpxnow" ident Creds "rpxnow" ident
$ maybe id (\x -> (:) ("verifiedEmail", x)) $ maybe id (\x -> (:) ("verifiedEmail", x))
(lookup "verifiedEmail" extra) (lookup "verifiedEmail" extra)
$ maybe id (\x -> (:) ("displayName", x)) $ maybe id (\x -> (:) ("displayName", x))
(getDisplayName extra) (fmap pack $ getDisplayName $ map (unpack *** unpack) extra)
[] []
setCreds True creds setCreds True creds
dispatch _ _ = notFound dispatch _ _ = notFound

26
yesod-auth.cabal
View File

@ -1,5 +1,5 @@
name: yesod-auth name: yesod-auth
version: 0.3.2 version: 0.4.0
license: BSD3 license: BSD3
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman, Patrick Brisbin author: Michael Snoyman, Patrick Brisbin
@ -19,28 +19,28 @@ library
cpp-options: -DGHC7 cpp-options: -DGHC7
else else
build-depends: base >= 4 && < 4.3 build-depends: base >= 4 && < 4.3
build-depends: authenticate >= 0.8.1 && < 0.9 build-depends: authenticate >= 0.9 && < 0.10
, bytestring >= 0.9.1.4 && < 0.10 , bytestring >= 0.9.1.4 && < 0.10
, yesod-core >= 0.7 && < 0.8 , yesod-core >= 0.8 && < 0.9
, wai >= 0.3 && < 0.4 , wai >= 0.4 && < 0.5
, template-haskell , template-haskell
, pureMD5 >= 1.1 && < 2.2 , pureMD5 >= 1.1 && < 2.2
, random >= 1.0 && < 1.1 , random >= 1.0 && < 1.1
, data-object >= 0.3.1.3 && < 0.4
, control-monad-attempt >= 0.3.0 && < 0.4 , control-monad-attempt >= 0.3.0 && < 0.4
, text >= 0.7 && < 0.12 , text >= 0.7 && < 0.12
, mime-mail >= 0.1 && < 0.2 , mime-mail >= 0.3 && < 0.4
, blaze-html >= 0.4 && < 0.5 , blaze-html >= 0.4 && < 0.5
, yesod-persistent >= 0.0 && < 0.1 , yesod-persistent >= 0.1 && < 0.2
, hamlet >= 0.7 && < 0.8 , hamlet >= 0.8 && < 0.9
, yesod-json >= 0.0 && < 0.1 , yesod-json >= 0.1 && < 0.2
, containers >= 0.2 && < 0.5 , containers >= 0.2 && < 0.5
, json-types >= 0.1 && < 0.2 , yesod-form >= 0.1 && < 0.2
, yesod-form >= 0.0 && < 0.1
, transformers >= 0.2 && < 0.3 , transformers >= 0.2 && < 0.3
, persistent >= 0.4 && < 0.5 , persistent >= 0.5 && < 0.6
, persistent-template >= 0.5 && < 0.6
, SHA >= 1.4.1.3 && < 1.5 , SHA >= 1.4.1.3 && < 1.5
, http-enumerator >= 0.3.1 && < 0.4 , http-enumerator >= 0.6 && < 0.7
, aeson >= 0.3.2.2 && < 0.4
exposed-modules: Yesod.Helpers.Auth exposed-modules: Yesod.Helpers.Auth
Yesod.Helpers.Auth.Dummy Yesod.Helpers.Auth.Dummy