module Yesod.Helpers.Auth
(
Auth
, AuthPlugin (..)
, AuthRoute (..)
, getAuth
, YesodAuth (..)
, Creds (..)
, setCreds
, maybeAuthId
, maybeAuth
, requireAuthId
, 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)
data Auth = Auth
type Method = String
type Piece = String
data AuthPlugin m = AuthPlugin
{ apName :: String
, apDispatch :: Method -> [Piece] -> GHandler Auth m ()
, apLogin :: forall s. (Route Auth -> Route m) -> GWidget s m ()
}
getAuth :: a -> Auth
getAuth = const Auth
data Creds m = Creds
{ credsPlugin :: String
, credsIdent :: String
, credsExtra :: [(String, String)]
}
class Yesod m => YesodAuth m where
type AuthId m
loginDest :: m -> Route m
logoutDest :: m -> Route m
getAuthId :: Creds m -> GHandler s m (Maybe (AuthId m))
showAuthId :: m -> AuthId m -> String
readAuthId :: m -> String -> Maybe (AuthId m)
authPlugins :: [AuthPlugin m]
loginHandler :: GHandler Auth m RepHtml
loginHandler = defaultLayout $ do
setTitle $ string "Login"
tm <- lift getRouteToMaster
mapM_ (flip apLogin tm) authPlugins
messageNoOpenID :: m -> Html
messageNoOpenID _ = string "No OpenID identifier found"
messageLoginOpenID :: m -> Html
messageLoginOpenID _ = string "Login via OpenID"
messageEmail :: m -> Html
messageEmail _ = string "Email"
messagePassword :: m -> Html
messagePassword _ = string "Password"
messageRegister :: m -> Html
messageRegister _ = string "Register"
messageRegisterLong :: m -> Html
messageRegisterLong _ = string "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."
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 ++ "."
messageAddressVerified :: m -> Html
messageAddressVerified _ = string "Address verified, please set a new password"
messageInvalidKeyTitle :: m -> Html
messageInvalidKeyTitle _ = string "Invalid verification key"
messageInvalidKey :: m -> Html
messageInvalidKey _ = string "I'm sorry, but that was an invalid verification key."
messageInvalidEmailPass :: m -> Html
messageInvalidEmailPass _ = string "Invalid email/password combination"
messageBadSetPass :: m -> Html
messageBadSetPass _ = string "You must be logged in to set a password"
messageSetPassTitle :: m -> Html
messageSetPassTitle _ = string "Set password"
messageSetPass :: m -> Html
messageSetPass _ = string "Set a new password"
messageNewPass :: m -> Html
messageNewPass _ = string "New password"
messageConfirmPass :: m -> Html
messageConfirmPass _ = string "Confirm"
messagePassMismatch :: m -> Html
messagePassMismatch _ = string "Passwords did not match, please try again"
messagePassUpdated :: m -> Html
messagePassUpdated _ = string "Password updated"
messageFacebook :: m -> Html
messageFacebook _ = string "Login with Facebook"
mkYesodSub "Auth"
[ ClassP ''YesodAuth [VarT $ mkName "master"]
]
#define STRINGS *Strings
#if GHC7
[parseRoutes|
#else
[$parseRoutes|
#endif
/check CheckR GET
/login LoginR GET
/logout LogoutR GET POST
/page/#String/STRINGS PluginR
|]
credsKey :: String
credsKey = "_ID"
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
<h1>Invalid login
|]
sendResponse rh
Just ar -> do
setMessage $ string "Invalid login"
redirect RedirectTemporary ar
else return ()
Just aid -> do
setSession credsKey $ showAuthId y aid
if doRedirects
then do
setMessage $ string "You are now logged in"
redirectUltDest RedirectTemporary $ loginDest y
else return ()
getCheckR :: YesodAuth m => GHandler Auth m RepHtmlJson
getCheckR = do
creds <- maybeAuthId
defaultLayoutJson (do
setTitle $ string "Authentication Status"
addHtml $ html creds) (json creds)
where
html creds =
#if GHC7
[hamlet|
#else
[$hamlet|
#endif
<h1>Authentication Status
$maybe _ <- creds
<p>Logged in.
$nothing
<p>Not logged in.
|]
json creds =
ValueObject $ Map.fromList
[ (pack "logged_in"
, ValueAtom $ AtomBoolean
$ maybe False (const True) creds)
]
getLoginR :: YesodAuth m => GHandler Auth m RepHtml
getLoginR = loginHandler
getLogoutR :: YesodAuth m => GHandler Auth m ()
getLogoutR = postLogoutR
postLogoutR :: YesodAuth m => GHandler Auth m ()
postLogoutR = do
y <- getYesod
deleteSession credsKey
redirectUltDest RedirectTemporary $ logoutDest y
handlePluginR :: YesodAuth m => String -> [String] -> GHandler Auth m ()
handlePluginR plugin pieces = do
env <- waiRequest
let method = S8.unpack $ W.requestMethod env
case filter (\x -> apName x == plugin) authPlugins of
[] -> notFound
ap:_ -> apDispatch ap method pieces
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
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"