-- | After login and logout, redirect to the referring page, instead of
-- 'loginDest' and 'logoutDest'. Default is 'False'.
redirectToReferer :: m -> Bool
redirectToReferer _ = False
-- | Return an HTTP connection manager that is stored in the foundation
-- type. This allows backends to reuse persistent connections. If none of
-- the backends you're using use HTTP connections, you can safely return
-- @error \"authHttpManager"@ here.
authHttpManager :: m -> Manager
-- | Called on a successful login. By default, calls
-- @setMessageI NowLoggedIn@.
onLogin :: GHandler s m ()
onLogin = setMessageI Msg.NowLoggedIn
-- | Called on logout. By default, does nothing
onLogout :: GHandler s m ()
onLogout = return ()
mkYesodSub "Auth"
[ ClassP ''YesodAuth [VarT $ mkName "master"]
]
#define STRINGS *Texts
[QQ(parseRoutes)|
/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 ->
when doRedirects $ do
case authRoute y of
Nothing -> do rh <- defaultLayout $ addHtml [QQ(shamlet)| <h1>Invalid login |]
sendResponse rh
Just ar -> do setMessageI Msg.InvalidLogin
redirect ar
Just aid -> do
setSession credsKey $ toPathPiece aid
when doRedirects $ do
onLogin
redirectUltDest $ loginDest y
getCheckR :: YesodAuth m => GHandler Auth m RepHtmlJson
getCheckR = do
creds <- maybeAuthId
defaultLayoutJson (do
setTitle "Authentication Status"
addHtml $ html' creds) (jsonCreds creds)
where
html' creds =
[QQ(shamlet)|
<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' :: YesodAuth master => GHandler sub master ()
setUltDestReferer' = do
m <- getYesod
when (redirectToReferer m) setUltDestReferer
getLoginR :: YesodAuth m => GHandler Auth m RepHtml
getLoginR = setUltDestReferer' >> loginHandler
getLogoutR :: YesodAuth m => GHandler Auth m ()
getLogoutR = setUltDestReferer' >> postLogoutR -- FIXME redirect to post
postLogoutR :: YesodAuth m => GHandler Auth m ()
postLogoutR = do
y <- getYesod
deleteSession credsKey
onLogout
redirectUltDest $ logoutDest y
handlePluginR :: YesodAuth m => Text -> [Text] -> GHandler Auth m ()
handlePluginR plugin pieces = do
master <- 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
-- | 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 $ fromPathPiece s
maybeAuth :: ( YesodAuth m
, b ~ YesodPersistBackend m
, b ~ PersistEntityBackend val
, Key b val ~ AuthId m
, PersistStore b (GHandler s m)
, PersistEntity val
, YesodPersist m
) => GHandler s m (Maybe (Entity val))
maybeAuth = runMaybeT $ do
aid <- MaybeT $ maybeAuthId
a <- MaybeT $ runDB $ get aid
return $ Entity aid a
requireAuthId :: YesodAuth m => GHandler s m (AuthId m)
requireAuthId = maybeAuthId >>= maybe redirectLogin return
requireAuth :: ( YesodAuth m
, b ~ YesodPersistBackend m
, b ~ PersistEntityBackend val
, Key b val ~ AuthId m
, PersistStore b (GHandler s m)
, PersistEntity val
, YesodPersist m
) => GHandler s m (Entity val)
requireAuth = maybeAuth >>= maybe redirectLogin return
redirectLogin :: Yesod m => GHandler s m a
redirectLogin = do
y <- getYesod
setUltDestCurrent
case authRoute y of
Just z -> redirect z
Nothing -> permissionDenied "Please configure authRoute"
