diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index cd88835d..eb3c3ec0 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -22,20 +22,13 @@ module Yesod.Helpers.Auth , 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 qualified Data.Map as Map import Control.Monad.Trans.Class (lift) import Data.Aeson @@ -66,7 +59,7 @@ data Creds m = Creds , 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 @@ -79,65 +72,62 @@ class Yesod m => YesodAuth m where getAuthId :: Creds m -> GHandler s m (Maybe (AuthId m)) - showAuthId :: m -> AuthId m -> Text - readAuthId :: m -> Text -> 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" + 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] @@ -180,14 +170,14 @@ setCreds doRedirects creds = do |] 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 () @@ -195,8 +185,8 @@ getCheckR :: YesodAuth m => GHandler Auth m RepHtmlJson 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 @@ -210,7 +200,7 @@ $maybe _ <- creds $nothing

Not logged in. |] - json creds = + json' creds = Object $ Map.fromList [ (T.pack "logged_in", Bool $ maybe False (const True) creds) ] @@ -239,10 +229,9 @@ handlePluginR plugin pieces = do 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 diff --git a/Yesod/Helpers/Auth/Email.hs b/Yesod/Helpers/Auth/Email.hs index dd8508d1..4c225e59 100644 --- a/Yesod/Helpers/Auth/Email.hs +++ b/Yesod/Helpers/Auth/Email.hs @@ -1,6 +1,7 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} module Yesod.Helpers.Auth.Email ( -- * Plugin authEmail @@ -55,12 +56,9 @@ data EmailCreds m = EmailCreds , 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 -> Text - readAuthEmailId :: m -> Text -> 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) @@ -104,9 +102,8 @@ authEmail = 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 @@ -151,7 +148,7 @@ postRegisterR = do 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 diff --git a/Yesod/Helpers/Auth/Facebook.hs b/Yesod/Helpers/Auth/Facebook.hs index 5517928e..26427995 100644 --- a/Yesod/Helpers/Auth/Facebook.hs +++ b/Yesod/Helpers/Auth/Facebook.hs @@ -17,11 +17,11 @@ import Yesod.Handler 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"] @@ -39,7 +39,7 @@ authFacebook cid secret perms = tm <- getRouteToMaster render <- getUrlRender let fb = Facebook.Facebook cid secret $ render $ tm url - redirectString RedirectTemporary $ Facebook.getForwardUrl fb perms + redirectText RedirectTemporary $ Facebook.getForwardUrl fb perms dispatch "GET" [] = do render <- getUrlRender tm <- getRouteToMaster @@ -67,6 +67,7 @@ authFacebook cid secret perms = #{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' diff --git a/Yesod/Helpers/Auth/HashDB.hs b/Yesod/Helpers/Auth/HashDB.hs index 42256282..42a90791 100644 --- a/Yesod/Helpers/Auth/HashDB.hs +++ b/Yesod/Helpers/Auth/HashDB.hs @@ -73,7 +73,6 @@ import Text.Hamlet (hamlet) import Control.Applicative ((<$>), (<*>)) import Data.ByteString.Lazy.Char8 (pack) import Data.Digest.Pure.SHA (sha1, showDigest) -import Database.Persist.TH (share2, mkMigrate, persist, mkPersist) import Data.Text (Text, unpack) import Data.Maybe (fromMaybe) diff --git a/Yesod/Helpers/Auth/OAuth.hs b/Yesod/Helpers/Auth/OAuth.hs index cabf51e7..4e8131d1 100644 --- a/Yesod/Helpers/Auth/OAuth.hs +++ b/Yesod/Helpers/Auth/OAuth.hs @@ -14,15 +14,14 @@ import Text.Hamlet (hamlet) import Web.Authenticate.OAuth import Data.Maybe import Data.String -import Network.HTTP.Enumerator 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 :: Text -> AuthRoute oauthUrl name = PluginR name ["forward"] @@ -50,11 +49,8 @@ authOAuth name ident reqUrl accUrl authUrl key sec = AuthPlugin name dispatch lo tm <- getRouteToMaster 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", encodeUtf8 verifier), ("oauth_token", encodeUtf8 oaTok) @@ -89,4 +85,5 @@ authTwitter = authOAuth "twitter" twitterUrl :: AuthRoute twitterUrl = oauthUrl "twitter" +bsToText :: ByteString -> Text bsToText = decodeUtf8With lenientDecode diff --git a/Yesod/Helpers/Auth/OpenId.hs b/Yesod/Helpers/Auth/OpenId.hs index cd7d6b47..91626169 100644 --- a/Yesod/Helpers/Auth/OpenId.hs +++ b/Yesod/Helpers/Auth/OpenId.hs @@ -16,9 +16,8 @@ import Yesod.Widget 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 @@ -64,10 +63,10 @@ authOpenId = res <- runAttemptT $ OpenId.getForwardUrl oid complete' Nothing [] attempt (\err -> do - setMessage $ string $ show err + setMessage $ toHtml $ show err redirect RedirectTemporary $ toMaster LoginR ) - (redirectString RedirectTemporary) + (redirectText RedirectTemporary) res _ -> do toMaster <- getRouteToMaster @@ -88,7 +87,7 @@ 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 [] diff --git a/Yesod/Helpers/Auth/Rpxnow.hs b/Yesod/Helpers/Auth/Rpxnow.hs index 03391799..f16f680b 100644 --- a/Yesod/Helpers/Auth/Rpxnow.hs +++ b/Yesod/Helpers/Auth/Rpxnow.hs @@ -14,7 +14,7 @@ import Yesod.Widget import Yesod.Request import Text.Hamlet (hamlet) import Control.Monad.IO.Class (liftIO) -import Data.Text (Text, pack, unpack) +import Data.Text (pack, unpack) import Control.Arrow ((***)) authRpxnow :: YesodAuth m