module Yesod.Helpers.Auth
(
Auth
, AuthPlugin (..)
, AuthRoute (..)
, getAuth
, YesodAuth (..)
, Creds (..)
, setCreds
, 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
data Creds m = Creds
{ credsPlugin :: Text
, credsIdent :: Text
, credsExtra :: [(Text, Text)]
}
class (Yesod m, SinglePiece (AuthId m)) => YesodAuth m where
type AuthId m
loginDest :: m -> Route m
logoutDest :: m -> Route m
getAuthId :: Creds m -> GHandler s m (Maybe (AuthId m))
authPlugins :: [AuthPlugin m]
loginHandler :: GHandler Auth m RepHtml
loginHandler = defaultLayout $ do
setTitle "Login"
tm <- lift getRouteToMaster
mapM_ (flip apLogin tm) authPlugins
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"
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 "Invalid login"
redirect RedirectTemporary ar
else return ()
Just aid -> do
setSession credsKey $ toSinglePiece aid
if doRedirects
then do
setMessage "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 "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 =
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
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
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"