{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Yesod.Auth.LdapNative -- Copyright : (C) 2015 Maciej Kazulak -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Maciej Kazulak -- Stability : experimental -- Portability : portable -- -- Yesod LDAP authentication plugin using Haskell native LDAP client. ---------------------------------------------------------------------------- module Yesod.Auth.LdapNative ( -- * Usage -- $use -- * Plugin Configuration authLdap , authLdapWithForm -- * LDAP Configuration , LdapAuthConf , LdapAuthQuery (..) , LdapCreds (..) , mkLdapConf , mkGroupQuery , setHost , setPort , setUserQuery , setGroupQuery , setDebug -- * Re-exports , L.Host (..) ) where import Yesod.Core import Yesod.Auth import Yesod.Form import Control.Applicative ((<$>), (<*>)) import Control.Exception (SomeException, IOException, Handler (..), catches) import Control.Monad.Trans.Either (EitherT (..), left) import Data.List.NonEmpty (NonEmpty (..), (<|)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Ldap.Client as L import qualified Ldap.Client.Bind as L import qualified Ldap.Client.Search as L pluginName :: Text pluginName = "ldap" loginRoute :: AuthRoute loginRoute = PluginR pluginName ["login"] -- | LDAP configuration. -- -- Details hidden on purpose. -- Use 'mkLdapConf' to create default config and functions below to adjust to taste. data LdapAuthConf = LdapAuthConf -- connection { host :: L.Host , port :: L.PortNumber , bindCreds :: Maybe LdapCreds -- queries , userQuery :: LdapAuthQuery , groupQuery :: Maybe LdapAuthQuery -- other , debug :: Int } -- | LDAP dn and password data LdapCreds = LdapCreds { lcDn :: L.Dn , lcPw :: L.Password } -- | Query parameters. -- -- Standard LDAP query parameters except filter is a function of the username. data LdapAuthQuery = LdapAuthQuery L.Dn (L.Mod L.Search) (Text -> L.Filter) [L.Attr] -- | Default LDAP configuration. mkLdapConf :: Maybe (Text, Text) -- ^ bindDn and bindPw -> Text -- ^ user query baseDn -> LdapAuthConf mkLdapConf mbindc baseDn = LdapAuthConf { host = L.Secure "localhost" , port = 636 , bindCreds = (\(dn,p) -> LdapCreds (L.Dn dn) (L.Password $ T.encodeUtf8 p)) <$> mbindc , userQuery = mkUserQuery baseDn , groupQuery = Nothing , debug = 0 } -- (Just (bindDn,bindPw)) -- | Default LDAP user query. mkUserQuery :: Text -- ^ baseDn -> LdapAuthQuery mkUserQuery baseDn = LdapAuthQuery (L.Dn baseDn) (L.scope L.WholeSubtree) (\u -> L.And $ L.Attr "objectClass" L.:= "posixAccount" <| L.Attr "uid" L.:= T.encodeUtf8 u :| [] ) [] -- | Default LDAP group query. mkGroupQuery :: Text -- ^ baseDn -> Text -- ^ group name attr -> Text -- ^ group name -> Text -- ^ member attr -> LdapAuthQuery mkGroupQuery baseDn groupAttr groupName memberAttr = LdapAuthQuery (L.Dn baseDn) (L.scope L.WholeSubtree) (\u -> L.And $ L.Attr "objectClass" L.:= "posixGroup" <| L.Attr groupAttr L.:= T.encodeUtf8 groupName <| L.Attr memberAttr L.:= T.encodeUtf8 u :| [] ) [] setHost :: L.Host -> LdapAuthConf -> LdapAuthConf setHost host conf = conf { host = host } setPort :: L.PortNumber -> LdapAuthConf -> LdapAuthConf setPort port conf = conf { port = port } setUserQuery :: LdapAuthQuery -> LdapAuthConf -> LdapAuthConf setUserQuery q conf = conf { userQuery = q } setGroupQuery :: Maybe LdapAuthQuery -> LdapAuthConf -> LdapAuthConf setGroupQuery q conf = conf { groupQuery = q } -- | Enable exact error messages. -- -- This will include LdapAuthError in alerts instead of a generic message. -- Do not use in production. setDebug :: Int -> LdapAuthConf -> LdapAuthConf setDebug level conf = conf { debug = level } authLdap :: YesodAuth m => LdapAuthConf -> AuthPlugin m authLdap conf = authLdapWithForm conf defaultForm authLdapWithForm :: (Yesod m, YesodAuth m) => LdapAuthConf -> (Route m -> WidgetT m IO ()) -> AuthPlugin m authLdapWithForm conf form = AuthPlugin pluginName (dispatch conf) $ \tp -> form (tp loginRoute) dispatch :: LdapAuthConf -> Text -> [Text] -> AuthHandler master TypedContent dispatch conf "POST" ["login"] = dispatchLdap conf dispatch _ _ _ = notFound -- | Returns the first value of each requested attr in credsExtra. Note this is only for -- convenience in common use cases ie. create a user if not exists but will only work in -- basic setups becase credsExtra is of type [(Text, Text)] - we loose type info and only -- get the first value. dispatchLdap :: (RenderMessage site FormMessage) => LdapAuthConf -> AuthHandler site TypedContent dispatchLdap conf = do tp <- getRouteToParent (username, password) <- lift $ runInputPost $ (,) <$> ireq textField "username" <*> ireq textField "password" eb <- liftIO $ -- not sure if we really should catch ALL exceptions here ldapLogin conf username password `catches` [Handler ioHandler, Handler catchAll] case eb of Left err -> do case debug conf > 0 of True -> setMessage $ [shamlet|Sign in failure. Error: #{show err}|] False -> setMessage $ [shamlet|Sign in failure. That is all we know right now. Try again later.|] lift $ redirect $ tp LoginR Right (L.SearchEntry _ attrs) -> do let extra = map f attrs lift $ setCredsRedirect $ Creds pluginName username extra where f (L.Attr k, x : _) = (k, T.decodeUtf8 x) f (L.Attr k, _) = (k, "") ioHandler :: IOException -> IO (Either LdapAuthError L.SearchEntry) ioHandler e = return $ Left $ IOException e catchAll :: SomeException -> IO (Either LdapAuthError L.SearchEntry) catchAll _ = return $ Left UnexpectedException -- | LDAP authentication error. data LdapAuthError = ResponseError L.ResponseError -- ^ Wraps "Ldap.Client" ResponseError. | LdapError L.LdapError -- ^ Wraps "Ldap.Client" LdapError. | ServiceBindError -- ^ Could not bind to directory using provided service credentials. | UserNotFoundError -- ^ 'userQuery' returned nothing. | MultipleUsersError -- ^ 'userQuery' returned multiple entries. You must either fix your query or your directory. | UserBindError -- ^ Could not bind as user. Probably wrong password. | GroupMembershipError -- ^ 'groupQuery' was configured but returned nothing. | IOException IOException -- ^ Probably connection error. | UnexpectedException -- ^ Everything else. deriving (Eq, Show) -- | LDAP authentication. ldapLogin :: LdapAuthConf -> Text -> Text -> IO (Either LdapAuthError L.SearchEntry) ldapLogin conf user pw = do res <- L.with (host conf) (port conf) $ \l -> runEitherT $ do -- service bind esb <- case bindCreds conf of Just c -> lift $ L.bindEither l (lcDn c) (lcPw c) Nothing -> return $ Right () case esb of Right _ -> return () Left _ -> left ServiceBindError -- user search eu <- lift $ query l (userQuery conf) user se@(L.SearchEntry dn _) <- case eu of Right (x : []) -> return x Right [] -> left UserNotFoundError Right _ -> left MultipleUsersError Left err -> left $ ResponseError err -- verify group membership if groupQuery was given let mg = groupQuery conf eg <- case mg of Just g -> lift $ query l g user Nothing -> return $ Right [] case eg of -- either becase groupQuery was not provided or returned nothing Right [] -> case mg of Just _ -> left GroupMembershipError Nothing -> return () Right _ -> return () Left err -> left $ ResponseError err -- user bind - verify password eub <- lift $ L.bindEither l dn (L.Password (T.encodeUtf8 pw)) case eub of Right _ -> return () Left _ -> left UserBindError return se case res of Left err -> return $ Left $ LdapError err Right x -> return x -- | Search helper. query :: L.Ldap -> LdapAuthQuery -> Text -> IO (Either L.ResponseError [L.SearchEntry]) query l (LdapAuthQuery baseDn mods filter attrs) login = L.searchEither l baseDn mods (filter login) attrs defaultForm :: Yesod app => Route app -> WidgetT app IO () defaultForm loginR = [whamlet|