module Yesod.Auth.Kerberos
( authKerberos,
genericAuthKerberos,
KerberosConfig(..),
defaultKerberosConfig
) where
#include "qq.h"
import Yesod.Auth
import Yesod.Auth.Message
import Web.Authenticate.Kerberos
import Data.Text (Text)
import qualified Data.Text as T
import Text.Hamlet
import Yesod.Core
import Yesod.Form
import Control.Applicative ((<$>), (<*>))
data KerberosConfig = KerberosConfig {
usernameModifier :: Text -> Text
, identifierModifier :: Text -> Text
}
defaultKerberosConfig :: KerberosConfig
defaultKerberosConfig = KerberosConfig id id
genericAuthKerberos :: YesodAuth m => KerberosConfig -> AuthPlugin m
genericAuthKerberos config = AuthPlugin "kerberos" dispatch $ \tm -> toWidget
[QQ(hamlet)|$newline never
<div id="header">
<h1>Login
<div id="login">
<form method="post" action="@{tm login}">
<table>
<tr>
<th>Username:
<td>
<input id="x" name="username" autofocus="" required>
<tr>
<th>Password:
<td>
<input type="password" name="password" required>
<tr>
<td>
<td>
<input type="submit" value="Login">
<script>
if (!("autofocus" in document.createElement("input"))) {
document.getElementById("x").focus();
}
|]
where
dispatch "POST" ["login"] = postLoginR config >>= sendResponse
dispatch _ _ = notFound
login :: AuthRoute
login = PluginR "kerberos" ["login"]
authKerberos :: YesodAuth m => AuthPlugin m
authKerberos = genericAuthKerberos defaultKerberosConfig
postLoginR :: (YesodAuth master) => KerberosConfig -> HandlerT Auth (HandlerT master IO) ()
postLoginR config = do
(mu,mp) <- lift $ runInputPost $ (,)
<$> iopt textField "username"
<*> iopt textField "password"
let errorMessage (message :: Text) = do
lift $ setMessage [QQ(shamlet)|$newline never
Error: #{message}
|]
redirect LoginR
case (mu,mp) of
(Nothing, _ ) -> do
mr <- lift getMessageRender
errorMessage $ mr PleaseProvideUsername
(_ , Nothing) -> do
mr <- lift getMessageRender
errorMessage $ mr PleaseProvidePassword
(Just u , Just p ) -> do
result <- liftIO $ loginKerberos (usernameModifier config u) p
case result of
Ok -> do
let creds = Creds
{ credsIdent = identifierModifier config u
, credsPlugin = "Kerberos"
, credsExtra = []
}
lift $ setCreds True creds
kerberosError -> errorMessage (T.pack $ show kerberosError)