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

yesod-auth on authenticate 1.0.0

Browse Source
This commit is contained in:
Michael Snoyman 2012-01-10 11:38:59 +02:00
parent ca9bb6e449
commit 1b3eb2b282
10 changed files with 50 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
authenticate

@ -1 +1 @@
Subproject commit 262d06e045b658e83abfc7a34c5f9878254c7046
Subproject commit 2a903feca1644fbef9c1c01bd5ae293f312f0b12

1
package-list.sh
View File

@ -7,6 +7,7 @@ pkgs=( ./yesod-routes
./yesod-persistent
./yesod-newsfeed
./yesod-form
./authenticate
./yesod-auth
./yesod-sitemap
./yesod-default

14
yesod-auth/Yesod/Auth.hs
View File

@ -34,11 +34,8 @@ import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Text (Text)
import qualified Data.Text as T
#if MIN_VERSION_aeson(0, 4, 0)
import qualified Data.HashMap.Lazy as Map
#else
import qualified Data.Map as Map
#endif
import Network.HTTP.Conduit (Manager)
import Language.Haskell.TH.Syntax hiding (lift)
@ -86,8 +83,10 @@ class (Yesod m, PathPiece (AuthId m), RenderMessage m FormMessage) => YesodAuth
-- destination exists.
logoutDest :: m -> Route m
-- | Determine the ID associated with the set of credentials.
getAuthId :: Creds m -> GHandler s m (Maybe (AuthId m))
-- | Which authentication backends to use.
authPlugins :: [AuthPlugin m]
-- | What to show on the login page.
@ -97,6 +96,7 @@ class (Yesod m, PathPiece (AuthId m), RenderMessage m FormMessage) => YesodAuth
tm <- lift getRouteToMaster
mapM_ (flip apLogin tm) authPlugins
-- | Used for i18n of messages provided by this package.
renderAuthMessage :: m
-> [Text] -- ^ languages
-> AuthMessage -> Text
@ -107,6 +107,12 @@ class (Yesod m, PathPiece (AuthId m), RenderMessage m FormMessage) => YesodAuth
redirectToReferer :: m -> Bool
redirectToReferer _ = False
-- | Return an HTTP connection manager that is stored in the foundation
-- type. This allows backends to reuse persistent connections. If none of
-- the backends you're using use HTTP connections, you can safely return
-- @error \"authHttpManager"@ here.
authHttpManager :: m -> Manager
mkYesodSub "Auth"
[ ClassP ''YesodAuth [VarT $ mkName "master"]
]

7
yesod-auth/Yesod/Auth/BrowserId.hs
View File

@ -12,7 +12,6 @@ import Web.Authenticate.BrowserId
import Data.Text (Text)
import Yesod.Core
import Text.Hamlet (hamlet)
import Control.Monad.IO.Class (liftIO)
import qualified Data.Text as T
import Data.Maybe (fromMaybe)
@ -32,7 +31,8 @@ authBrowserIdAudience audience = AuthPlugin
, apDispatch = \m ps ->
case (m, ps) of
("GET", [assertion]) -> do
memail <- liftIO $ checkAssertion audience assertion
master <- getYesod
memail <- lift $ checkAssertion audience assertion (authHttpManager master)
case memail of
Nothing -> error "Invalid assertion"
Just email -> setCreds True Creds
@ -60,7 +60,8 @@ authBrowserId = AuthPlugin
tm <- getRouteToMaster
r <- getUrlRender
let audience = T.takeWhile (/= '/') $ stripScheme $ r $ tm LoginR
memail <- liftIO $ checkAssertion audience assertion
master <- getYesod
memail <- lift $ checkAssertion audience assertion (authHttpManager master)
case memail of
Nothing -> error "Invalid assertion"
Just email -> setCreds True Creds

5
yesod-auth/Yesod/Auth/Facebook.hs
View File

@ -77,10 +77,11 @@ authFacebook cid secret perms =
tm <- getRouteToMaster
let fb = Facebook.Facebook cid secret $ render $ tm url
code <- runInputGet $ ireq textField "code"
at <- liftIO $ Facebook.getAccessToken fb code
master <- getYesod
at <- lift $ Facebook.getAccessToken fb code (authHttpManager master)
let Facebook.AccessToken at' = at
setSession facebookAccessTokenKey at'
so <- liftIO $ Facebook.getGraphData at "me"
so <- lift $ Facebook.getGraphData at "me" (authHttpManager master)
let c = fromMaybe (error "Invalid response from Facebook")
$ parseMaybe (parseCreds at') $ either error id so
setCreds True c

20
yesod-auth/Yesod/Auth/GoogleEmail.hs
View File

@ -17,7 +17,6 @@ module Yesod.Auth.GoogleEmail
import Yesod.Auth
import qualified Web.Authenticate.OpenId as OpenId
import Control.Monad.Attempt
import Yesod.Form
import Yesod.Handler
@ -27,6 +26,7 @@ import Text.Blaze (toHtml)
import Data.Text (Text)
import qualified Yesod.Auth.Message as Msg
import qualified Data.Text as T
import Control.Exception.Lifted (try, SomeException)
forwardUrl :: AuthRoute
forwardUrl = PluginR "googleemail" ["forward"]
@ -50,21 +50,22 @@ authGoogleEmail =
render <- getUrlRender
toMaster <- getRouteToMaster
let complete' = render $ toMaster complete
res <- runAttemptT $ OpenId.getForwardUrl oid complete' Nothing
master <- getYesod
eres <- lift $ try $ OpenId.getForwardUrl oid complete' Nothing
[ ("openid.ax.type.email", "http://schema.openid.net/contact/email")
, ("openid.ns.ax", "http://openid.net/srv/ax/1.0")
, ("openid.ns.ax.required", "email")
, ("openid.ax.mode", "fetch_request")
, ("openid.ax.required", "email")
, ("openid.ui.icon", "true")
]
attempt
] (authHttpManager master)
either
(\err -> do
setMessage $ toHtml $ show err
setMessage $ toHtml $ show (err :: SomeException)
redirect $ toMaster LoginR
)
redirect
res
eres
Nothing -> do
toMaster <- getRouteToMaster
setMessageI Msg.NoOpenID
@ -81,10 +82,11 @@ authGoogleEmail =
completeHelper :: YesodAuth m => [(Text, Text)] -> GHandler Auth m ()
completeHelper gets' = do
res <- runAttemptT $ OpenId.authenticate gets'
master <- getYesod
eres <- lift $ try $ OpenId.authenticate gets' (authHttpManager master)
toMaster <- getRouteToMaster
let onFailure err = do
setMessage $ toHtml $ show err
setMessage $ toHtml $ show (err :: SomeException)
redirect $ toMaster LoginR
let onSuccess (OpenId.Identifier ident, _) = do
memail <- lookupGetParam "openid.ext1.value.email"
@ -96,4 +98,4 @@ completeHelper gets' = do
(Nothing, _) -> do
setMessage "No email address provided"
redirect $ toMaster LoginR
attempt onFailure onSuccess res
either onFailure onSuccess eres

9
yesod-auth/Yesod/Auth/OAuth.hs
View File

@ -19,7 +19,6 @@ import Data.Maybe
import Data.String
import Data.ByteString.Char8 (pack)
import Control.Arrow ((***))
import Control.Monad.IO.Class (liftIO)
import Data.Text (Text, unpack)
import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
@ -52,15 +51,17 @@ authOAuth name ident reqUrl accUrl authUrl key sec = AuthPlugin name dispatch lo
render <- getUrlRender
tm <- getRouteToMaster
let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url }
tok <- liftIO $ getTemporaryCredential oauth'
master <- getYesod
tok <- lift $ getTemporaryCredential oauth' (authHttpManager master)
redirect $ authorizeUrl oauth' tok
dispatch "GET" [] = do
(verifier, oaTok) <- runInputGet $ (,)
<$> ireq textField "oauth_verifier"
<*> ireq textField "oauth_token"
let reqTok = Credential [ ("oauth_verifier", encodeUtf8 verifier), ("oauth_token", encodeUtf8 oaTok)
]
accTok <- liftIO $ getAccessToken oauth reqTok
]
master <- getYesod
accTok <- lift $ getAccessToken oauth reqTok (authHttpManager master)
let crId = decodeUtf8With lenientDecode $ fromJust $ lookup (pack ident) $ unCredential accTok
creds = Creds name crId $ map (bsToText *** bsToText ) $ unCredential accTok
setCreds True creds

22
yesod-auth/Yesod/Auth/OpenId.hs
View File

@ -11,7 +11,6 @@ module Yesod.Auth.OpenId
import Yesod.Auth
import qualified Web.Authenticate.OpenId as OpenId
import Control.Monad.Attempt
import Yesod.Form
import Yesod.Handler
@ -21,6 +20,7 @@ import Text.Cassius (cassius)
import Text.Blaze (toHtml)
import Data.Text (Text)
import qualified Yesod.Auth.Message as Msg
import Control.Exception.Lifted (SomeException, try)
forwardUrl :: AuthRoute
forwardUrl = PluginR "openid" ["forward"]
@ -60,14 +60,13 @@ authOpenIdExtended extensionFields =
render <- getUrlRender
toMaster <- getRouteToMaster
let complete' = render $ toMaster complete
res <- runAttemptT $ OpenId.getForwardUrl oid complete' Nothing extensionFields
attempt
(\err -> do
setMessage $ toHtml $ show err
master <- getYesod
eres <- lift $ try $ OpenId.getForwardUrl oid complete' Nothing extensionFields (authHttpManager master)
case eres of
Left err -> do
setMessage $ toHtml $ show (err :: SomeException)
redirect $ toMaster LoginR
)
redirect
res
Right x -> redirect x
Nothing -> do
toMaster <- getRouteToMaster
setMessageI Msg.NoOpenID
@ -84,11 +83,12 @@ authOpenIdExtended extensionFields =
completeHelper :: YesodAuth m => [(Text, Text)] -> GHandler Auth m ()
completeHelper gets' = do
res <- runAttemptT $ OpenId.authenticate gets'
master <- getYesod
eres <- lift $ try $ OpenId.authenticate gets' (authHttpManager master)
toMaster <- getRouteToMaster
let onFailure err = do
setMessage $ toHtml $ show err
setMessage $ toHtml $ show (err :: SomeException)
redirect $ toMaster LoginR
let onSuccess (OpenId.Identifier ident, _) =
setCreds True $ Creds "openid" ident gets'
attempt onFailure onSuccess res
either onFailure onSuccess eres

3
yesod-auth/Yesod/Auth/Rpxnow.hs
View File

@ -38,7 +38,8 @@ authRpxnow app apiKey =
token <- case token1 ++ token2 of
[] -> invalidArgs ["token: Value not supplied"]
x:_ -> return $ unpack x
Rpxnow.Identifier ident extra <- liftIO $ Rpxnow.authenticate apiKey token
master <- getYesod
Rpxnow.Identifier ident extra <- lift $ Rpxnow.authenticate apiKey token (authHttpManager master)
let creds =
Creds "rpxnow" ident
$ maybe id (\x -> (:) ("verifiedEmail", x))

4
yesod-auth/yesod-auth.cabal
View File

@ -21,14 +21,13 @@ library
cpp-options: -DGHC7
else
build-depends: base >= 4 && < 4.3
build-depends: authenticate >= 0.11.1 && < 0.12
build-depends: authenticate >= 1.0 && < 1.1
, bytestring >= 0.9.1.4 && < 0.10
, yesod-core >= 0.10 && < 0.11
, wai >= 1.0 && < 1.1
, template-haskell
, pureMD5 >= 2.0 && < 2.2
, random >= 1.0.0.2 && < 1.1
, control-monad-attempt >= 0.3.0 && < 0.4
, text >= 0.7 && < 0.12
, mime-mail >= 0.3 && < 0.5
, blaze-html >= 0.4.1.3 && < 0.5
@ -46,6 +45,7 @@ library
, http-conduit >= 1.1 && < 1.2
, aeson >= 0.5
, pwstore-fast >= 2.2 && < 3
, lifted-base >= 0.1 && < 0.2
exposed-modules: Yesod.Auth
Yesod.Auth.BrowserId