yesod-auth 0.3.2 → 0.4.0
raw patch · 9 files changed
+175/−156 lines, 9 filesdep +aesondep +persistent-templatedep −data-objectdep −json-typesdep ~authenticatedep ~hamletdep ~http-enumerator
Dependencies added: aeson, persistent-template
Dependencies removed: data-object, json-types
Dependency ranges changed: authenticate, hamlet, http-enumerator, mime-mail, persistent, wai, yesod-core, yesod-form, yesod-json, yesod-persistent
Files
- Yesod/Helpers/Auth.hs +54/−58
- Yesod/Helpers/Auth/Dummy.hs +1/−0
- Yesod/Helpers/Auth/Email.hs +23/−20
- Yesod/Helpers/Auth/Facebook.hs +27/−18
- Yesod/Helpers/Auth/HashDB.hs +25/−21
- Yesod/Helpers/Auth/OAuth.hs +16/−14
- Yesod/Helpers/Auth/OpenId.hs +7/−6
- Yesod/Helpers/Auth/Rpxnow.hs +9/−6
- yesod-auth.cabal +13/−13
Yesod/Helpers/Auth.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} module Yesod.Helpers.Auth ( -- * Subsite Auth@@ -21,31 +22,29 @@ , requireAuth ) where -import Yesod.Handler import Yesod.Core-import Yesod.Widget-import Yesod.Content-import Yesod.Dispatch import Yesod.Persist-import Yesod.Request import Yesod.Json import Text.Blaze import Language.Haskell.TH.Syntax hiding (lift)-import qualified Data.ByteString.Char8 as S8 import qualified Network.Wai as W import Text.Hamlet (hamlet)-import Data.Text.Lazy (pack)-import Data.JSON.Types (Value (..), Atom (AtomBoolean)) import qualified Data.Map as Map 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 -type Method = String-type Piece = String+type Method = Text+type Piece = Text data AuthPlugin m = AuthPlugin- { apName :: String+ { apName :: Text , apDispatch :: Method -> [Piece] -> GHandler Auth m () , apLogin :: forall s. (Route Auth -> Route m) -> GWidget s m () }@@ -55,12 +54,12 @@ -- | User credentials data Creds m = Creds- { credsPlugin :: String -- ^ How the user was authenticated- , credsIdent :: String -- ^ Identifier. Exact meaning depends on plugin.- , credsExtra :: [(String, String)]+ { credsPlugin :: Text -- ^ How the user was authenticated+ , credsIdent :: Text -- ^ Identifier. Exact meaning depends on plugin.+ , credsExtra :: [(Text, Text)] } -class Yesod m => YesodAuth m where+class (Yesod m, SinglePiece (AuthId m)) => YesodAuth m where type AuthId m -- | Default destination on successful login, if no other@@ -73,69 +72,69 @@ getAuthId :: Creds m -> GHandler s m (Maybe (AuthId m)) - showAuthId :: m -> AuthId m -> String- readAuthId :: m -> String -> Maybe (AuthId m)- authPlugins :: [AuthPlugin m] -- | What to show on the login page. loginHandler :: GHandler Auth m RepHtml loginHandler = defaultLayout $ do- setTitle $ string "Login"+ setTitle "Login" tm <- lift getRouteToMaster mapM_ (flip apLogin tm) authPlugins ----- Message strings. In theory in the future make this localizable ----- See gist: https://gist.github.com/778712 messageNoOpenID :: m -> Html- messageNoOpenID _ = string "No OpenID identifier found"+ messageNoOpenID _ = "No OpenID identifier found" messageLoginOpenID :: m -> Html- messageLoginOpenID _ = string "Login via OpenID"+ messageLoginOpenID _ = "Login via OpenID" messageEmail :: m -> Html- messageEmail _ = string "Email"+ messageEmail _ = "Email" messagePassword :: m -> Html- messagePassword _ = string "Password"+ messagePassword _ = "Password" messageRegister :: m -> Html- messageRegister _ = string "Register"+ messageRegister _ = "Register" messageRegisterLong :: m -> Html- messageRegisterLong _ = string "Register a new account"+ messageRegisterLong _ = "Register a new account" messageEnterEmail :: m -> Html- messageEnterEmail _ = string "Enter your e-mail address below, and a confirmation e-mail will be sent to you."+ messageEnterEmail _ = "Enter your e-mail address below, and a confirmation e-mail will be sent to you." messageConfirmationEmailSentTitle :: m -> Html- messageConfirmationEmailSentTitle _ = string "Confirmation e-mail sent"- messageConfirmationEmailSent :: m -> String -> Html- messageConfirmationEmailSent _ email = string $ "A confirmation e-mail has been sent to " ++ email ++ "."+ messageConfirmationEmailSentTitle _ = "Confirmation e-mail sent"+ messageConfirmationEmailSent :: m -> Text -> Html+ messageConfirmationEmailSent _ email = toHtml $ mconcat+ ["A confirmation e-mail has been sent to ", email, "."] messageAddressVerified :: m -> Html- messageAddressVerified _ = string "Address verified, please set a new password"+ messageAddressVerified _ = "Address verified, please set a new password" messageInvalidKeyTitle :: m -> Html- messageInvalidKeyTitle _ = string "Invalid verification key"+ messageInvalidKeyTitle _ = "Invalid verification key" messageInvalidKey :: m -> Html- messageInvalidKey _ = string "I'm sorry, but that was an invalid verification key."+ messageInvalidKey _ = "I'm sorry, but that was an invalid verification key." messageInvalidEmailPass :: m -> Html- messageInvalidEmailPass _ = string "Invalid email/password combination"+ messageInvalidEmailPass _ = "Invalid email/password combination" messageBadSetPass :: m -> Html- messageBadSetPass _ = string "You must be logged in to set a password"+ messageBadSetPass _ = "You must be logged in to set a password" messageSetPassTitle :: m -> Html- messageSetPassTitle _ = string "Set password"+ messageSetPassTitle _ = "Set password" messageSetPass :: m -> Html- messageSetPass _ = string "Set a new password"+ messageSetPass _ = "Set a new password" messageNewPass :: m -> Html- messageNewPass _ = string "New password"+ messageNewPass _ = "New password" messageConfirmPass :: m -> Html- messageConfirmPass _ = string "Confirm"+ messageConfirmPass _ = "Confirm" messagePassMismatch :: m -> Html- messagePassMismatch _ = string "Passwords did not match, please try again"+ messagePassMismatch _ = "Passwords did not match, please try again" messagePassUpdated :: m -> Html- messagePassUpdated _ = string "Password updated"+ messagePassUpdated _ = "Password updated" messageFacebook :: m -> Html- messageFacebook _ = string "Login with Facebook"+ messageFacebook _ = "Login with Facebook" +type Texts = [Text]+ mkYesodSub "Auth" [ ClassP ''YesodAuth [VarT $ mkName "master"] ]-#define STRINGS *Strings+#define STRINGS *Texts #if GHC7 [parseRoutes| #else@@ -144,10 +143,10 @@ /check CheckR GET /login LoginR GET /logout LogoutR GET POST-/page/#String/STRINGS PluginR+/page/#Text/STRINGS PluginR |] -credsKey :: String+credsKey :: Text credsKey = "_ID" -- | FIXME: won't show up till redirect@@ -171,14 +170,14 @@ |] sendResponse rh Just ar -> do- setMessage $ string "Invalid login"+ setMessage "Invalid login" redirect RedirectTemporary ar else return () Just aid -> do- setSession credsKey $ showAuthId y aid+ setSession credsKey $ toSinglePiece aid if doRedirects then do- setMessage $ string "You are now logged in"+ setMessage "You are now logged in" redirectUltDest RedirectTemporary $ loginDest y else return () @@ -186,8 +185,8 @@ getCheckR = do creds <- maybeAuthId defaultLayoutJson (do- setTitle $ string "Authentication Status"- addHtml $ html creds) (json creds)+ setTitle "Authentication Status"+ addHtml $ html creds) (json' creds) where html creds = #if GHC7@@ -201,11 +200,9 @@ $nothing <p>Not logged in. |]- json creds =- ValueObject $ Map.fromList- [ (pack "logged_in"- , ValueAtom $ AtomBoolean- $ maybe False (const True) creds)+ json' creds =+ Object $ Map.fromList+ [ (T.pack "logged_in", Bool $ maybe False (const True) creds) ] getLoginR :: YesodAuth m => GHandler Auth m RepHtml@@ -220,10 +217,10 @@ deleteSession credsKey redirectUltDest RedirectTemporary $ logoutDest y -handlePluginR :: YesodAuth m => String -> [String] -> GHandler Auth m ()+handlePluginR :: YesodAuth m => Text -> [Text] -> GHandler Auth m () handlePluginR plugin pieces = do env <- waiRequest- let method = S8.unpack $ W.requestMethod env+ let method = decodeUtf8With lenientDecode $ W.requestMethod env case filter (\x -> apName x == plugin) authPlugins of [] -> notFound ap:_ -> apDispatch ap method pieces@@ -232,10 +229,9 @@ 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+ Just s -> return $ fromSinglePiece s maybeAuth :: ( YesodAuth m , Key val ~ AuthId m
Yesod/Helpers/Auth/Dummy.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} -- | Provides a dummy authentication module that simply lets a user specify -- his/her identifier. This is not intended for real world use, just for -- testing.
Yesod/Helpers/Auth/Email.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-} module Yesod.Helpers.Auth.Email ( -- * Plugin authEmail@@ -19,7 +21,9 @@ import Control.Applicative ((<$>), (<*>)) import Data.Digest.Pure.MD5 import qualified Data.Text.Lazy as T+import qualified Data.Text as TS import Data.Text.Lazy.Encoding (encodeUtf8)+import Data.Text (Text) import Yesod.Form import Yesod.Handler@@ -35,13 +39,13 @@ registerR = PluginR "email" ["register"] setpassR = PluginR "email" ["set-password"] -verify :: String -> String -> AuthRoute -- FIXME+verify :: Text -> Text -> AuthRoute -- FIXME verify eid verkey = PluginR "email" ["verify", eid, verkey] -type Email = String-type VerKey = String-type VerUrl = String-type SaltedPass = String+type Email = Text+type VerKey = Text+type VerUrl = Text+type SaltedPass = Text type VerStatus = Bool -- | Data stored in a database for each e-mail address.@@ -52,12 +56,9 @@ , emailCredsVerkey :: Maybe VerKey } -class YesodAuth m => YesodAuthEmail m where+class (YesodAuth m, SinglePiece (AuthEmailId 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)@@ -69,10 +70,10 @@ getEmail :: AuthEmailId m -> GHandler Auth m (Maybe Email) -- | Generate a random alphanumeric string.- randomKey :: m -> IO String+ randomKey :: m -> IO Text randomKey _ = do stdgen <- newStdGen- return $ fst $ randomString 10 stdgen+ return $ TS.pack $ fst $ randomString 10 stdgen authEmail :: YesodAuthEmail m => AuthPlugin m authEmail =@@ -101,9 +102,8 @@ where dispatch "GET" ["register"] = getRegisterR >>= sendResponse dispatch "POST" ["register"] = postRegisterR >>= sendResponse- dispatch "GET" ["verify", eid, verkey] = do- y <- getYesod- case readAuthEmailId y eid of+ dispatch "GET" ["verify", eid, verkey] =+ case fromSinglePiece eid of Nothing -> notFound Just eid' -> getVerifyR eid' verkey >>= sendResponse dispatch "POST" ["login"] = postLoginR >>= sendResponse@@ -148,7 +148,7 @@ return (lid, key) render <- getUrlRender tm <- getRouteToMaster- let verUrl = render $ tm $ verify (showAuthEmailId y lid) verKey+ let verUrl = render $ tm $ verify (toSinglePiece lid) verKey sendVerifyEmail email verKey verUrl defaultLayout $ do setTitle $ messageConfirmationEmailSentTitle y@@ -162,7 +162,7 @@ |] getVerifyR :: YesodAuthEmail m- => AuthEmailId m -> String -> GHandler Auth m RepHtml+ => AuthEmailId m -> Text -> GHandler Auth m RepHtml getVerifyR lid key = do realKey <- getVerifyKey lid memail <- getEmail lid@@ -274,11 +274,11 @@ saltLength = 5 -- | Salt a password with a randomly generated salt.-saltPass :: String -> IO String+saltPass :: Text -> IO Text saltPass pass = do stdgen <- newStdGen 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' salt pass =@@ -286,9 +286,12 @@ where fromString = encodeUtf8 . T.pack -isValidPass :: String -- ^ cleartext password+isValidPass :: Text -- ^ cleartext password -> SaltedPass -- ^ salted password -> Bool-isValidPass clear salted =+isValidPass clear' salted' = let salt = take saltLength salted in salted == saltPass' salt clear+ where+ clear = TS.unpack clear'+ salted = TS.unpack salted'
Yesod/Helpers/Auth/Facebook.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} module Yesod.Helpers.Auth.Facebook ( authFacebook , facebookUrl@@ -7,7 +8,8 @@ import Yesod.Helpers.Auth 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 Yesod.Form@@ -15,16 +17,19 @@ import Yesod.Widget import Text.Hamlet (hamlet) import Control.Monad.IO.Class (liftIO)-import qualified Data.ByteString.Char8 as S8 import Control.Monad.Trans.Class (lift)+import Data.Text (Text)+import Control.Monad (mzero)+import Data.Monoid (mappend)+import qualified Data.Aeson.Types facebookUrl :: AuthRoute facebookUrl = PluginR "facebook" ["forward"] authFacebook :: YesodAuth m- => String -- ^ Application ID- -> String -- ^ Application secret- -> [String] -- ^ Requested permissions+ => Text -- ^ Application ID+ -> Text -- ^ Application secret+ -> [Text] -- ^ Requested permissions -> AuthPlugin m authFacebook cid secret perms = AuthPlugin "facebook" dispatch login@@ -34,7 +39,7 @@ tm <- getRouteToMaster render <- getUrlRender let fb = Facebook.Facebook cid secret $ render $ tm url- redirectString RedirectTemporary $ S8.pack $ Facebook.getForwardUrl fb perms+ redirectText RedirectTemporary $ Facebook.getForwardUrl fb perms dispatch "GET" [] = do render <- getUrlRender tm <- getRouteToMaster@@ -43,18 +48,8 @@ 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')- ]+ let c = fromMaybe (error "Invalid response from Facebook")+ $ parseMaybe (parseCreds at') $ either error id so setCreds True c dispatch _ _ = notFound login tm = do@@ -71,3 +66,17 @@ <p> <a href="#{furl}">#{messageFacebook y} |]++parseCreds :: Text -> Value -> Data.Aeson.Types.Parser (Creds m)+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
Yesod/Helpers/Auth/HashDB.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------- -- | -- Module : Yesod.Helpers.Auth.HashDB@@ -72,8 +73,8 @@ import Control.Applicative ((<$>), (<*>)) import Data.ByteString.Lazy.Char8 (pack) import Data.Digest.Pure.SHA (sha1, showDigest)-import Database.Persist.TH (share2)-import Database.Persist.GenericSql (mkMigrate)+import Data.Text (Text, unpack)+import Data.Maybe (fromMaybe) -- | Computer the sha1 of a string and return it as a string sha1String :: String -> String@@ -87,8 +88,8 @@ [$persist| #endif User- username String Eq- password String+ username Text Eq+ password Text UniqueUser username |] @@ -96,14 +97,14 @@ -- database values validateUser :: (YesodPersist y, PersistBackend (YesodDB y (GGHandler sub y IO))) - => (String, String) + => (Text, Text) -> GHandler sub y Bool validateUser (user,password) = runDB (getBy $ UniqueUser user) >>= \dbUser -> case dbUser of -- user not found Nothing -> return False -- validate password- Just (_, sqlUser) -> return $ sha1String password == userPassword sqlUser+ Just (_, sqlUser) -> return $ sha1String (unpack password) == unpack (userPassword sqlUser) login :: AuthRoute login = PluginR "hashdb" ["login"]@@ -114,14 +115,17 @@ PersistBackend (YesodDB y (GGHandler Auth y IO))) => GHandler Auth y () postLoginR = do- (user, password) <- runFormPost' $ (,)- <$> stringInput "username"- <*> stringInput "password"+ (mu,mp) <- runFormPost' $ (,)+ <$> maybeStringInput "username"+ <*> maybeStringInput "password" - isValid <- validateUser (user,password)+ isValid <- case (mu,mp) of+ (Nothing, _ ) -> return False+ (_ , Nothing) -> return False+ (Just u , Just p ) -> validateUser (u,p) if isValid- then setCreds True $ Creds "hashdb" user []+ then setCreds True $ Creds "hashdb" (fromMaybe "" mu) [] else do setMessage #if GHC7@@ -129,7 +133,7 @@ #else [$hamlet| #endif- <em>invalid username/password+ Invalid username/password |] toMaster <- getRouteToMaster redirect RedirectTemporary $ toMaster LoginR@@ -160,7 +164,7 @@ #else [$hamlet| #endif- <em>user not found+ User not found |] redirect RedirectTemporary $ authR LoginR @@ -178,28 +182,28 @@ #endif <div id="header"> <h1>Login-\+ <div id="login"> <form method="post" action="@{tm login}"> <table> <tr> <th>Username: <td>- <input id="x" name="username" autofocus="">+ <input id="x" name="username" autofocus="" required> <tr> <th>Password: <td>- <input type="password" name="password">+ <input type="password" name="password" required> <tr> <td> <td> <input type="submit" value="Login">-\+ <script>- \if (!("autofocus" in document.createElement("input"))) {- \document.getElementById("x").focus();- \}- \+ if (!("autofocus" in document.createElement("input"))) {+ document.getElementById("x").focus();+ }+ |] where dispatch "POST" ["login"] = postLoginR >>= sendResponse
Yesod/Helpers/Auth/OAuth.hs view
@@ -14,18 +14,20 @@ import Web.Authenticate.OAuth import Data.Maybe import Data.String-import Network.HTTP.Enumerator-import Data.ByteString.Char8 (unpack, pack)+import Data.ByteString.Char8 (pack) import Control.Arrow ((***))-import Control.Monad import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Class (lift)+import Data.Text (Text, unpack)+import Data.Text.Encoding (encodeUtf8, decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import Data.ByteString (ByteString) -oauthUrl :: String -> AuthRoute+oauthUrl :: Text -> AuthRoute oauthUrl name = PluginR name ["forward"] authOAuth :: YesodAuth m =>- String -- ^ Service Name+ Text -- ^ Service Name -> String -- ^ OAuth Parameter Name to use for identify -> String -- ^ Request URL -> String -- ^ Access Token URL@@ -36,7 +38,7 @@ authOAuth name ident reqUrl accUrl authUrl key sec = AuthPlugin name dispatch login where url = PluginR name []- oauth = OAuth { oauthServerName = name, oauthRequestUri = reqUrl+ oauth = OAuth { oauthServerName = unpack name, oauthRequestUri = reqUrl , oauthAccessTokenUri = accUrl, oauthAuthorizeUri = authUrl , oauthSignatureMethod = HMACSHA1 , oauthConsumerKey = fromString key, oauthConsumerSecret = fromString sec@@ -45,20 +47,17 @@ dispatch "GET" ["forward"] = do render <- getUrlRender tm <- getRouteToMaster- let oauth' = oauth { oauthCallback = Just $ fromString $ render $ tm url }+ let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url } tok <- liftIO $ getTemporaryCredential oauth'- redirectString RedirectTemporary (fromString $ authorizeUrl oauth' tok)+ redirectText RedirectTemporary (fromString $ authorizeUrl oauth' tok) dispatch "GET" [] = do- render <- getUrlRender- tm <- getRouteToMaster- let callback = render $ tm url verifier <- runFormGet' $ stringInput "oauth_verifier" 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- let crId = unpack $ fromJust $ lookup (pack ident) $ unCredential accTok- creds = Creds name crId $ map (unpack *** unpack) $ unCredential accTok+ let crId = decodeUtf8With lenientDecode $ fromJust $ lookup (pack ident) $ unCredential accTok+ creds = Creds name crId $ map (bsToText *** bsToText ) $ unCredential accTok setCreds True creds dispatch _ _ = notFound login tm = do@@ -85,3 +84,6 @@ twitterUrl :: AuthRoute twitterUrl = oauthUrl "twitter"++bsToText :: ByteString -> Text+bsToText = decodeUtf8With lenientDecode
Yesod/Helpers/Auth/OpenId.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} module Yesod.Helpers.Auth.OpenId ( authOpenId , forwardUrl@@ -15,9 +16,9 @@ import Yesod.Request import Text.Hamlet (hamlet) import Text.Cassius (cassius)-import Text.Blaze (string)+import Text.Blaze (toHtml) import Control.Monad.Trans.Class (lift)-import qualified Data.ByteString.Char8 as S8+import Data.Text (Text) forwardUrl :: AuthRoute forwardUrl = PluginR "openid" ["forward"]@@ -62,10 +63,10 @@ res <- runAttemptT $ OpenId.getForwardUrl oid complete' Nothing [] attempt (\err -> do- setMessage $ string $ show err+ setMessage $ toHtml $ show err redirect RedirectTemporary $ toMaster LoginR )- (redirectString RedirectTemporary . S8.pack)+ (redirectText RedirectTemporary) res _ -> do toMaster <- getRouteToMaster@@ -81,12 +82,12 @@ completeHelper posts dispatch _ _ = notFound -completeHelper :: YesodAuth m => [(String, String)] -> GHandler Auth m ()+completeHelper :: YesodAuth m => [(Text, Text)] -> GHandler Auth m () completeHelper gets' = do res <- runAttemptT $ OpenId.authenticate gets' toMaster <- getRouteToMaster let onFailure err = do- setMessage $ string $ show err+ setMessage $ toHtml $ show err redirect RedirectTemporary $ toMaster LoginR let onSuccess (OpenId.Identifier ident, _) = setCreds True $ Creds "openid" ident []
Yesod/Helpers/Auth/Rpxnow.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} module Yesod.Helpers.Auth.Rpxnow ( authRpxnow ) where@@ -13,6 +14,8 @@ import Yesod.Request import Text.Hamlet (hamlet) import Control.Monad.IO.Class (liftIO)+import Data.Text (pack, unpack)+import Control.Arrow ((***)) authRpxnow :: YesodAuth m => String -- ^ app name@@ -32,18 +35,18 @@ <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+ token1 <- lookupGetParams "token"+ token2 <- lookupPostParams "token"+ token <- case token1 ++ token2 of+ [] -> invalidArgs ["token: Value not supplied"]+ x:_ -> return $ unpack 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)+ (fmap pack $ getDisplayName $ map (unpack *** unpack) extra) [] setCreds True creds dispatch _ _ = notFound
yesod-auth.cabal view
@@ -1,5 +1,5 @@ name: yesod-auth-version: 0.3.2+version: 0.4.0 license: BSD3 license-file: LICENSE author: Michael Snoyman, Patrick Brisbin@@ -19,28 +19,28 @@ cpp-options: -DGHC7 else 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- , yesod-core >= 0.7 && < 0.8- , wai >= 0.3 && < 0.4+ , yesod-core >= 0.8 && < 0.9+ , wai >= 0.4 && < 0.5 , template-haskell , pureMD5 >= 1.1 && < 2.2 , random >= 1.0 && < 1.1- , data-object >= 0.3.1.3 && < 0.4 , control-monad-attempt >= 0.3.0 && < 0.4 , text >= 0.7 && < 0.12- , mime-mail >= 0.1 && < 0.2+ , mime-mail >= 0.3 && < 0.4 , blaze-html >= 0.4 && < 0.5- , yesod-persistent >= 0.0 && < 0.1- , hamlet >= 0.7 && < 0.8- , yesod-json >= 0.0 && < 0.1+ , yesod-persistent >= 0.1 && < 0.2+ , hamlet >= 0.8 && < 0.9+ , yesod-json >= 0.1 && < 0.2 , containers >= 0.2 && < 0.5- , json-types >= 0.1 && < 0.2- , yesod-form >= 0.0 && < 0.1+ , yesod-form >= 0.1 && < 0.2 , 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- , 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 Yesod.Helpers.Auth.Dummy