module Yesod.Auth.Ldap where
import Prelude
import Yesod.Core
import Yesod.Auth
import Yesod.Form
import Control.Monad
import Data.Text (Text)
import qualified Data.Text as Text
import Control.Applicative
import LDAP.Init
import LDAP.Exceptions
import Data.Monoid
import Data.Aeson
data LdapCreds = LdapCreds
{ ldapUser :: Text
, ldapPassword :: Text
, ldapPort :: Int
, ldapHost :: Text
, ldapPrefix :: Text
}
instance FromJSON LdapCreds where
parseJSON (Object o) = LdapCreds
<$> o .: "user"
<*> o .: "password"
<*> o .: "port"
<*> o .: "host"
<*> o .: "prefix"
parseJSON _ = mzero
ldapPluginName :: Text
ldapPluginName = "ldap"
class YesodLdap site where
getLdapCreds :: HandlerT site IO LdapCreds
l3AuthLdap :: (RenderMessage site FormMessage, YesodAuth site, YesodLdap site) => AuthPlugin site
l3AuthLdap = AuthPlugin ldapPluginName dispatch $ \tp -> [whamlet|
<h2>AD Login
<form action="@{tp (PluginR "ldap" ["login"])}" method=post>
<p>Log in below using your active directory credentials.
<div.formgroup>
<label>Username
<input.formcontrol type="text" name="username">
<div.formgroup>
<label>Password
<input.formcontrol type="password" name="password">
<button.btn.btnprimary type="submit">Submit
|]
dispatch :: (RenderMessage site FormMessage, YesodAuth site, YesodLdap site) => Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
dispatch "POST" ["login"] = dispatchLdap
dispatch _ _ = notFound
dispatchLdap :: (RenderMessage site FormMessage, YesodAuth site, YesodLdap site) => HandlerT Auth (HandlerT site IO) TypedContent
dispatchLdap = do
tp <- getRouteToParent
creds <- lift getLdapCreds
(username,password) <- lift $ runInputPost $ (,)
<$> ireq textField "username"
<*> ireq textField "password"
let qualifiedUsername = ldapPrefix creds <> username
success <- liftIO $ do
conn <- ldapOpen (Text.unpack $ ldapHost creds) (fromInteger $ toInteger $ ldapPort creds)
ldapBoolifyExceptions $ ldapSimpleBind conn (Text.unpack qualifiedUsername) (Text.unpack password)
lift $ if success
then do
setCredsRedirect $ Creds ldapPluginName username []
else do
setMessage $ [shamlet|<div.alert.alertdanger>Could not log in|]
redirect $ tp LoginR
ldapBoolifyExceptions :: IO () -> IO Bool
ldapBoolifyExceptions a = catchLDAP (True <$ a) (\_ -> return False)