module Yesod.Auth
(
Auth
, AuthRoute
, Route (..)
, AuthPlugin (..)
, getAuth
, YesodAuth (..)
, YesodAuthPersist
, AuthEntity
, Creds (..)
, setCreds
, clearCreds
, defaultMaybeAuthId
, maybeAuth
, requireAuthId
, requireAuth
, AuthException (..)
, AuthHandler
) where
import Control.Monad (when)
import Control.Monad.Trans.Maybe
import Yesod.Auth.Routes
import Data.Aeson
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.HashMap.Lazy as Map
import Network.HTTP.Conduit (Manager)
import qualified Network.Wai as W
import Text.Hamlet (shamlet)
import Yesod.Core
import Yesod.Persist
import Yesod.Auth.Message (AuthMessage, defaultMessage)
import qualified Yesod.Auth.Message as Msg
import Yesod.Form (FormMessage)
import Data.Typeable (Typeable)
import Control.Exception (Exception)
type AuthRoute = Route Auth
type AuthHandler master a = YesodAuth master => HandlerT Auth (HandlerT master IO) a
type Method = Text
type Piece = Text
data AuthPlugin master = AuthPlugin
{ apName :: Text
, apDispatch :: Method -> [Piece] -> AuthHandler master ()
, apLogin :: (Route Auth -> Route master) -> WidgetT master IO ()
}
getAuth :: a -> Auth
getAuth = const Auth
data Creds master = Creds
{ credsPlugin :: Text
, credsIdent :: Text
, credsExtra :: [(Text, Text)]
}
class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage) => YesodAuth master where
type AuthId master
loginDest :: master -> Route master
logoutDest :: master -> Route master
getAuthId :: Creds master -> HandlerT master IO (Maybe (AuthId master))
authPlugins :: master -> [AuthPlugin master]
loginHandler :: AuthHandler master RepHtml
loginHandler = do
tp <- getRouteToParent
lift $ defaultLayout $ do
setTitleI Msg.LoginTitle
master <- getYesod
mapM_ (flip apLogin tp) (authPlugins master)
renderAuthMessage :: master
-> [Text]
-> AuthMessage
-> Text
renderAuthMessage _ _ = defaultMessage
redirectToReferer :: master -> Bool
redirectToReferer _ = False
authHttpManager :: master -> Manager
onLogin :: HandlerT master IO ()
onLogin = setMessageI Msg.NowLoggedIn
onLogout :: HandlerT master IO ()
onLogout = return ()
maybeAuthId :: HandlerT master IO (Maybe (AuthId master))
default maybeAuthId
:: ( YesodAuth master
, PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val
, b ~ YesodPersistBackend master
, Key val ~ AuthId master
, PersistStore (b (HandlerT master IO))
, PersistEntity val
, YesodPersist master
, Typeable val
)
=> HandlerT master IO (Maybe (AuthId master))
maybeAuthId = defaultMaybeAuthId
credsKey :: Text
credsKey = "_ID"
defaultMaybeAuthId
:: ( YesodAuth master
, PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val
, b ~ YesodPersistBackend master
, Key val ~ AuthId master
, PersistStore (b (HandlerT master IO))
, PersistEntity val
, YesodPersist master
, Typeable val
) => HandlerT master IO (Maybe (AuthId master))
defaultMaybeAuthId = do
ms <- lookupSession credsKey
case ms of
Nothing -> return Nothing
Just s ->
case fromPathPiece s of
Nothing -> return Nothing
Just aid -> fmap (fmap entityKey) $ cachedAuth aid
cachedAuth :: ( YesodAuth master
, PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val
, b ~ YesodPersistBackend master
, Key val ~ AuthId master
, PersistStore (b (HandlerT master IO))
, PersistEntity val
, YesodPersist master
, Typeable val
) => AuthId master -> HandlerT master IO (Maybe (Entity val))
cachedAuth aid = runMaybeT $ do
a <- MaybeT $ fmap unCachedMaybeAuth
$ cached
$ fmap CachedMaybeAuth
$ runDB
$ get aid
return $ Entity aid a
setCreds :: YesodAuth master
=> Bool
-> Creds master
-> HandlerT master IO ()
setCreds doRedirects creds = do
y <- getYesod
maid <- getAuthId creds
case maid of
Nothing -> when doRedirects $ do
case authRoute y of
Nothing -> do
res <- selectRep $ do
provideRep $ defaultLayout $ toWidget [shamlet|<h1>Invalid login|]
provideRep $ return $ object ["message" .= ("Invalid Login" :: Text)]
sendResponse res
Just ar -> do
res <- selectRep $ do
provideRepType typeHtml $ do
setMessageI Msg.InvalidLogin
_ <- redirect ar
return ()
provideRep $ return $ object ["message" .= ("Invalid Login" :: Text)]
sendResponse res
Just aid -> do
setSession credsKey $ toPathPiece aid
when doRedirects $ do
onLogin
res <- selectRep $ do
provideRepType typeHtml $ do
_ <- redirectUltDest $ loginDest y
return ()
provideRep $ return $ object ["message" .= ("Login Successful" :: Text)]
sendResponse res
clearCreds :: YesodAuth master
=> Bool
-> HandlerT master IO ()
clearCreds doRedirects = do
y <- getYesod
deleteSession credsKey
when doRedirects $ do
onLogout
redirectUltDest $ logoutDest y
getCheckR :: AuthHandler master TypedContent
getCheckR = lift $ do
creds <- maybeAuthId
defaultLayoutJson (do
setTitle "Authentication Status"
toWidget $ html' creds) (return $ jsonCreds creds)
where
html' creds =
[shamlet|
$newline never
<h1>Authentication Status
$maybe _ <- creds
<p>Logged in.
$nothing
<p>Not logged in.
|]
jsonCreds creds =
Object $ Map.fromList
[ (T.pack "logged_in", Bool $ maybe False (const True) creds)
]
setUltDestReferer' :: AuthHandler master ()
setUltDestReferer' = lift $ do
master <- getYesod
when (redirectToReferer master) setUltDestReferer
getLoginR :: AuthHandler master RepHtml
getLoginR = setUltDestReferer' >> loginHandler
getLogoutR :: AuthHandler master ()
getLogoutR = setUltDestReferer' >> redirectToPost LogoutR
postLogoutR :: AuthHandler master ()
postLogoutR = lift $ clearCreds True
handlePluginR :: Text -> [Text] -> AuthHandler master ()
handlePluginR plugin pieces = do
master <- lift getYesod
env <- waiRequest
let method = decodeUtf8With lenientDecode $ W.requestMethod env
case filter (\x -> apName x == plugin) (authPlugins master) of
[] -> notFound
ap:_ -> apDispatch ap method pieces
maybeAuth :: ( YesodAuth master
, PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val
, b ~ YesodPersistBackend master
, Key val ~ AuthId master
, PersistStore (b (HandlerT master IO))
, PersistEntity val
, YesodPersist master
, Typeable val
) => HandlerT master IO (Maybe (Entity val))
maybeAuth = runMaybeT $ do
aid <- MaybeT maybeAuthId
MaybeT $ cachedAuth aid
newtype CachedMaybeAuth val = CachedMaybeAuth { unCachedMaybeAuth :: Maybe val }
deriving Typeable
type YesodAuthPersist master =
( YesodAuth master
, PersistMonadBackend (YesodPersistBackend master (HandlerT master IO))
~ PersistEntityBackend (AuthEntity master)
, Key (AuthEntity master) ~ AuthId master
, PersistStore (YesodPersistBackend master (HandlerT master IO))
, PersistEntity (AuthEntity master)
, YesodPersist master
, Typeable (AuthEntity master)
)
type AuthEntity master = KeyEntity (AuthId master)
requireAuthId :: YesodAuthPersist master => HandlerT master IO (AuthId master)
requireAuthId = maybeAuthId >>= maybe redirectLogin return
requireAuth :: YesodAuthPersist master => HandlerT master IO (Entity (AuthEntity master))
requireAuth = maybeAuth >>= maybe redirectLogin return
redirectLogin :: Yesod master => HandlerT master IO a
redirectLogin = do
y <- getYesod
setUltDestCurrent
case authRoute y of
Just z -> redirect z
Nothing -> permissionDenied "Please configure authRoute"
instance YesodAuth master => RenderMessage master AuthMessage where
renderMessage = renderAuthMessage
data AuthException = InvalidBrowserIDAssertion
| InvalidFacebookResponse
deriving (Show, Typeable)
instance Exception AuthException
instance YesodAuth master => YesodSubDispatch Auth (HandlerT master IO) where
yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth)