chore(auth): campus->ldap
This commit is contained in:
parent
c929d42ebd
commit
a42ccb0faa
162
src/Auth/LDAP.hs
162
src/Auth/LDAP.hs
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Felix Hamann <felix.hamann@campus.lmu.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <jost@cip.ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
@ -9,9 +9,9 @@ module Auth.LDAP
|
||||
, ADError(..), ADInvalidCredentials(..)
|
||||
, campusLogin
|
||||
, CampusUserException(..)
|
||||
, campusUser, campusUser', campusUser''
|
||||
, campusUserReTest, campusUserReTest'
|
||||
, campusUserMatr, campusUserMatr'
|
||||
, ldapUser, ldapUser', ldapUser''
|
||||
, ldapUserReTest, ldapUserReTest'
|
||||
, ldapUserMatr, ldapUserMatr'
|
||||
, CampusMessage(..)
|
||||
, ldapPrimaryKey
|
||||
, ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
|
||||
@ -24,20 +24,25 @@ module Auth.LDAP
|
||||
|
||||
import Import.NoFoundation
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Utils.Metrics
|
||||
import Utils.Form
|
||||
import Auth.LDAP.AD
|
||||
|
||||
import qualified Ldap.Client as Ldap
|
||||
|
||||
import Utils.Form
|
||||
import Utils.Metrics
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.Text.Encoding as Text
|
||||
|
||||
import qualified Yesod.Auth.Message as Msg
|
||||
|
||||
import Auth.LDAP.AD
|
||||
|
||||
-- allow Ldap.Attr usage as key for Data.Map
|
||||
-- | Plugin name of the LDAP yesod auth plugin
|
||||
apLdap :: Text
|
||||
apLdap = "LDAP"
|
||||
|
||||
|
||||
-- | Allow Ldap.Attr usage as key for Data.Map
|
||||
deriving newtype instance Ord Ldap.Attr
|
||||
|
||||
|
||||
@ -53,7 +58,11 @@ data CampusMessage = MsgCampusIdentPlaceholder
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
|
||||
|
||||
findUser :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
|
||||
findUser :: LdapConf
|
||||
-> Ldap
|
||||
-> Text -- ^ needle
|
||||
-> [Ldap.Attr]
|
||||
-> IO [Ldap.SearchEntry]
|
||||
findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase $ userSearchSettings conf) retAttrs) userFilters
|
||||
where
|
||||
userFilters =
|
||||
@ -69,14 +78,19 @@ findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM
|
||||
[ ldapUserFraportPersonalnummer Ldap.:= Text.encodeUtf8 ident
|
||||
]
|
||||
|
||||
findUserMatr :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
|
||||
findUserMatr :: LdapConf
|
||||
-> Ldap
|
||||
-> Text -- ^ matriculation needle
|
||||
-> [Ldap.Attr]
|
||||
-> IO [Ldap.SearchEntry]
|
||||
findUserMatr conf@LdapConf{..} ldap userMatr retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase $ userSearchSettings conf) retAttrs) userFilters
|
||||
where
|
||||
userFilters =
|
||||
[ ldapUserFraportPersonalnummer Ldap.:= Text.encodeUtf8 userMatr
|
||||
]
|
||||
|
||||
userSearchSettings :: LdapConf -> Ldap.Mod Ldap.Search
|
||||
userSearchSettings :: LdapConf
|
||||
-> Ldap.Mod Ldap.Search
|
||||
userSearchSettings LdapConf{..} = mconcat
|
||||
[ Ldap.scope ldapScope
|
||||
, Ldap.size 2
|
||||
@ -104,6 +118,7 @@ ldapUserEmail = Ldap.Attr "mail" :|
|
||||
]
|
||||
|
||||
|
||||
-- TODO: rename
|
||||
data CampusUserException = CampusUserLdapError LdapPoolError
|
||||
| CampusUserNoResult
|
||||
| CampusUserAmbiguous
|
||||
@ -113,20 +128,21 @@ instance Exception CampusUserException
|
||||
|
||||
makePrisms ''CampusUserException
|
||||
|
||||
campusUserWith :: ( MonadUnliftIO m
|
||||
, MonadCatch m
|
||||
)
|
||||
=> ( Lens (LdapConf, LdapPool) (LdapConf, Ldap) LdapPool Ldap
|
||||
|
||||
ldapUserWith :: ( MonadUnliftIO m
|
||||
, MonadCatch m
|
||||
)
|
||||
=> ( Lens (LdapConf, LdapPool) (LdapConf, Ldap) LdapPool Ldap
|
||||
-> Failover (LdapConf, LdapPool)
|
||||
-> FailoverMode
|
||||
-> ((LdapConf, Ldap) -> m (Either CampusUserException (Ldap.AttrList [])))
|
||||
-> m (Either LdapPoolError (Either CampusUserException (Ldap.AttrList [])))
|
||||
)
|
||||
-> Failover (LdapConf, LdapPool)
|
||||
-> FailoverMode
|
||||
-> Creds site
|
||||
-> m (Either CampusUserException (Ldap.AttrList []))
|
||||
campusUserWith withLdap' pool mode Creds{..} = either (throwM . CampusUserLdapError) return <=< withLdap' _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO . runExceptT $ do
|
||||
)
|
||||
-> Failover (LdapConf, LdapPool)
|
||||
-> FailoverMode
|
||||
-> Creds site
|
||||
-> m (Either CampusUserException (Ldap.AttrList []))
|
||||
ldapUserWith withLdap' pool mode Creds{..} = either (throwM . CampusUserLdapError) return <=< withLdap' _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO . runExceptT $ do
|
||||
lift $ Ldap.bind ldap ldapDn ldapPassword
|
||||
results <- case lookup "DN" credsExtra of
|
||||
Just userDN -> do
|
||||
@ -139,28 +155,74 @@ campusUserWith withLdap' pool mode Creds{..} = either (throwM . CampusUserLdapEr
|
||||
[Ldap.SearchEntry _ attrs] -> return attrs
|
||||
_otherwise -> throwE CampusUserAmbiguous
|
||||
|
||||
campusUserReTest :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> Creds site -> m (Ldap.AttrList [])
|
||||
campusUserReTest pool doTest mode creds = throwLeft =<< campusUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool mode creds
|
||||
|
||||
campusUserReTest' :: (MonadMask m, MonadLogger m, MonadUnliftIO m) => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList []))
|
||||
campusUserReTest' pool doTest mode User{userIdent,userLdapPrimaryKey}
|
||||
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUserReTest pool doTest mode (Creds apLdap upsertIdent [])
|
||||
ldapUserReTest :: ( MonadUnliftIO m
|
||||
, MonadMask m
|
||||
, MonadLogger m
|
||||
)
|
||||
=> Failover (LdapConf, LdapPool)
|
||||
-> (Nano -> Bool)
|
||||
-> FailoverMode
|
||||
-> Creds site
|
||||
-> m (Ldap.AttrList [])
|
||||
ldapUserReTest pool doTest mode creds = throwLeft =<< ldapUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool mode creds
|
||||
|
||||
ldapUserReTest' :: ( MonadMask m
|
||||
, MonadLogger m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> Failover (LdapConf, LdapPool)
|
||||
-> (Nano -> Bool)
|
||||
-> FailoverMode
|
||||
-> User
|
||||
-> m (Maybe (Ldap.AttrList []))
|
||||
ldapUserReTest' pool doTest mode User{userIdent,userLdapPrimaryKey}
|
||||
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ ldapUserReTest pool doTest mode (Creds apLdap upsertIdent [])
|
||||
where upsertIdent = fromMaybe (CI.original userIdent) userLdapPrimaryKey
|
||||
|
||||
|
||||
campusUser :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> Creds site -> m (Ldap.AttrList [])
|
||||
campusUser pool mode creds = throwLeft =<< campusUserWith withLdapFailover pool mode creds
|
||||
ldapUser :: ( MonadMask m
|
||||
, MonadUnliftIO m
|
||||
, MonadLogger m
|
||||
)
|
||||
=> Failover (LdapConf, LdapPool)
|
||||
-> FailoverMode
|
||||
-> Creds site
|
||||
-> m (Ldap.AttrList [])
|
||||
ldapUser pool mode creds = throwLeft =<< ldapUserWith withLdapFailover pool mode creds
|
||||
|
||||
campusUser' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList []))
|
||||
campusUser' pool mode User{userIdent}
|
||||
= campusUser'' pool mode $ CI.original userIdent
|
||||
ldapUser' :: ( MonadMask m
|
||||
, MonadUnliftIO m
|
||||
, MonadLogger m
|
||||
)
|
||||
=> Failover (LdapConf, LdapPool)
|
||||
-> FailoverMode
|
||||
-> User
|
||||
-> m (Maybe (Ldap.AttrList []))
|
||||
ldapUser' pool mode User{userIdent}
|
||||
= ldapUser'' pool mode $ CI.original userIdent
|
||||
|
||||
campusUser'' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> Text -> m (Maybe (Ldap.AttrList []))
|
||||
campusUser'' pool mode ident
|
||||
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser pool mode (Creds apLdap ident [])
|
||||
ldapUser'' :: ( MonadMask m
|
||||
, MonadUnliftIO m
|
||||
, MonadLogger m
|
||||
)
|
||||
=> Failover (LdapConf, LdapPool)
|
||||
-> FailoverMode
|
||||
-> Text
|
||||
-> m (Maybe (Ldap.AttrList []))
|
||||
ldapUser'' pool mode ident
|
||||
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ ldapUser pool mode (Creds apLdap ident [])
|
||||
|
||||
campusUserMatr :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Ldap.AttrList [])
|
||||
campusUserMatr pool mode userMatr = either (throwM . CampusUserLdapError) return <=< withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO $ do
|
||||
|
||||
ldapUserMatr :: ( MonadUnliftIO m
|
||||
, MonadMask m
|
||||
, MonadLogger m
|
||||
)
|
||||
=> Failover (LdapConf, LdapPool)
|
||||
-> FailoverMode
|
||||
-> UserMatriculation
|
||||
-> m (Ldap.AttrList [])
|
||||
ldapUserMatr pool mode userMatr = either (throwM . CampusUserLdapError) return <=< withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO $ do
|
||||
Ldap.bind ldap ldapDn ldapPassword
|
||||
results <- findUserMatr conf ldap userMatr []
|
||||
case results of
|
||||
@ -168,10 +230,16 @@ campusUserMatr pool mode userMatr = either (throwM . CampusUserLdapError) return
|
||||
[Ldap.SearchEntry _ attrs] -> return attrs
|
||||
_otherwise -> throwM CampusUserAmbiguous
|
||||
|
||||
campusUserMatr' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Maybe (Ldap.AttrList []))
|
||||
campusUserMatr' pool mode
|
||||
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . campusUserMatr pool mode
|
||||
|
||||
ldapUserMatr' :: ( MonadMask m
|
||||
, MonadUnliftIO m
|
||||
, MonadLogger m
|
||||
)
|
||||
=> Failover (LdapConf, LdapPool)
|
||||
-> FailoverMode
|
||||
-> UserMatriculation
|
||||
-> m (Maybe (Ldap.AttrList []))
|
||||
ldapUserMatr' pool mode
|
||||
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . ldapUserMatr pool mode
|
||||
|
||||
|
||||
newtype ADInvalidCredentials = ADInvalidCredentials ADError
|
||||
@ -186,15 +254,14 @@ campusForm :: ( RenderMessage (HandlerSite m) FormMessage
|
||||
, RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m))
|
||||
, RenderMessage (HandlerSite m) CampusMessage
|
||||
, MonadHandler m
|
||||
) => WForm m (FormResult CampusLogin)
|
||||
)
|
||||
=> WForm m (FormResult CampusLogin)
|
||||
campusForm = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
aFormToWForm $ CampusLogin
|
||||
<$> areq ciField (fslpI MsgCampusIdent (mr MsgCampusIdentPlaceholder) & addAttr "autofocus" "" & addAttr "autocomplete" "username") Nothing
|
||||
<*> areq passwordField (fslpI MsgCampusPassword (mr MsgCampusPasswordPlaceholder) & addAttr "autocomplete" "current-password") Nothing
|
||||
|
||||
apLdap :: Text
|
||||
apLdap = "LDAP"
|
||||
|
||||
campusLogin :: forall site.
|
||||
( YesodAuth site
|
||||
@ -203,7 +270,10 @@ campusLogin :: forall site.
|
||||
, RenderMessage site (ValueRequired site)
|
||||
, RenderMessage site ADInvalidCredentials
|
||||
, Button site ButtonSubmit
|
||||
) => Failover (LdapConf, LdapPool) -> FailoverMode -> AuthPlugin site
|
||||
)
|
||||
=> Failover (LdapConf, LdapPool)
|
||||
-> FailoverMode
|
||||
-> AuthPlugin site
|
||||
campusLogin pool mode = AuthPlugin{..}
|
||||
where
|
||||
apName :: Text
|
||||
|
||||
Loading…
Reference in New Issue
Block a user