Logged in. -$nothing -
Not logged in. -|] - json' creds = - Object $ Map.fromList - [ (T.pack "logged_in", Bool $ maybe False (const True) creds) - ] - -getLoginR :: YesodAuth m => GHandler Auth m RepHtml -getLoginR = loginHandler - -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 $ logoutDest y - -handlePluginR :: YesodAuth m => Text -> [Text] -> GHandler Auth m () -handlePluginR plugin pieces = do - env <- waiRequest - let method = decodeUtf8With lenientDecode $ 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 - case ms of - Nothing -> return Nothing - Just s -> return $ fromSinglePiece s - -maybeAuth :: ( YesodAuth m - , Key val ~ AuthId m - , PersistBackend (YesodDB m (GGHandler s m IO)) - , 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 (GGHandler s m IO)) - , 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" +{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Yesod.Helpers.Auth + ( -- * Subsite + Auth + , AuthPlugin (..) + , AuthRoute (..) + , getAuth + , YesodAuth (..) + -- * Plugin interface + , Creds (..) + , setCreds + -- * User functions + , maybeAuthId + , maybeAuth + , requireAuthId + , requireAuth + ) where + +import Yesod.Core +import Yesod.Persist +import Yesod.Json +import Text.Blaze +import Language.Haskell.TH.Syntax hiding (lift) +import qualified Network.Wai as W +import Text.Hamlet (hamlet) +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) +import Web.Routes.Quasi (toSinglePiece, fromSinglePiece) + +data Auth = Auth + +type Method = Text +type Piece = Text + +data AuthPlugin m = AuthPlugin + { apName :: Text + , apDispatch :: Method -> [Piece] -> GHandler Auth m () + , apLogin :: forall s. (Route Auth -> Route m) -> GWidget s m () + } + +getAuth :: a -> Auth +getAuth = const Auth + +-- | User credentials +data Creds m = Creds + { credsPlugin :: Text -- ^ How the user was authenticated + , credsIdent :: Text -- ^ Identifier. Exact meaning depends on plugin. + , credsExtra :: [(Text, Text)] + } + +class (Yesod m, SinglePiece (AuthId m)) => YesodAuth m where + type AuthId m + + -- | Default destination on successful login, if no other + -- destination exists. + loginDest :: m -> Route m + + -- | Default destination on successful logout, if no other + -- destination exists. + logoutDest :: m -> Route m + + getAuthId :: Creds m -> GHandler s m (Maybe (AuthId m)) + + authPlugins :: [AuthPlugin m] + + -- | What to show on the login page. + loginHandler :: GHandler Auth m RepHtml + loginHandler = defaultLayout $ do + 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 _ = "No OpenID identifier found" + messageLoginOpenID :: m -> Html + messageLoginOpenID _ = "Login via OpenID" + + messageEmail :: m -> Html + messageEmail _ = "Email" + messagePassword :: m -> Html + messagePassword _ = "Password" + messageRegister :: m -> Html + messageRegister _ = "Register" + messageRegisterLong :: m -> Html + messageRegisterLong _ = "Register a new account" + messageEnterEmail :: m -> Html + messageEnterEmail _ = "Enter your e-mail address below, and a confirmation e-mail will be sent to you." + messageConfirmationEmailSentTitle :: m -> Html + 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 _ = "Address verified, please set a new password" + messageInvalidKeyTitle :: m -> Html + messageInvalidKeyTitle _ = "Invalid verification key" + messageInvalidKey :: m -> Html + messageInvalidKey _ = "I'm sorry, but that was an invalid verification key." + messageInvalidEmailPass :: m -> Html + messageInvalidEmailPass _ = "Invalid email/password combination" + messageBadSetPass :: m -> Html + messageBadSetPass _ = "You must be logged in to set a password" + messageSetPassTitle :: m -> Html + messageSetPassTitle _ = "Set password" + messageSetPass :: m -> Html + messageSetPass _ = "Set a new password" + messageNewPass :: m -> Html + messageNewPass _ = "New password" + messageConfirmPass :: m -> Html + messageConfirmPass _ = "Confirm" + messagePassMismatch :: m -> Html + messagePassMismatch _ = "Passwords did not match, please try again" + messagePassUpdated :: m -> Html + messagePassUpdated _ = "Password updated" + + messageFacebook :: m -> Html + messageFacebook _ = "Login with Facebook" + +type Texts = [Text] + +mkYesodSub "Auth" + [ ClassP ''YesodAuth [VarT $ mkName "master"] + ] +#define STRINGS *Texts +#if GHC7 + [parseRoutes| +#else + [$parseRoutes| +#endif +/check CheckR GET +/login LoginR GET +/logout LogoutR GET POST +/page/#Text/STRINGS PluginR +|] + +credsKey :: Text +credsKey = "_ID" + +-- | FIXME: won't show up till redirect +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 +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif +
Logged in. +$nothing +
Not logged in. +|] + json' creds = + Object $ Map.fromList + [ (T.pack "logged_in", Bool $ maybe False (const True) creds) + ] + +getLoginR :: YesodAuth m => GHandler Auth m RepHtml +getLoginR = loginHandler + +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 $ logoutDest y + +handlePluginR :: YesodAuth m => Text -> [Text] -> GHandler Auth m () +handlePluginR plugin pieces = do + env <- waiRequest + let method = decodeUtf8With lenientDecode $ 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 + case ms of + Nothing -> return Nothing + Just s -> return $ fromSinglePiece s + +maybeAuth :: ( YesodAuth m + , Key val ~ AuthId m + , PersistBackend (YesodDB m (GGHandler s m IO)) + , 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 (GGHandler s m IO)) + , 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" diff --git a/Yesod/Helpers/Auth/Dummy.hs b/Yesod/Helpers/Auth/Dummy.hs --- a/Yesod/Helpers/Auth/Dummy.hs +++ b/Yesod/Helpers/Auth/Dummy.hs @@ -1,35 +1,35 @@ -{-# 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. -module Yesod.Helpers.Auth.Dummy - ( authDummy - ) where - -import Yesod.Helpers.Auth -import Yesod.Form (runFormPost', stringInput) -import Yesod.Handler (notFound) -import Text.Hamlet (hamlet) - -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" [] - login authToMaster = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -