fraport/fradrive-old
fraport/fradrive-old
Archived
3
1
Fork 0
Code Issues 65 Pull Requests 5 Actions Packages Projects Releases 197 Wiki Activity

chore(auth): campus->ldap

Browse Source
This commit is contained in:
Sarah Vaupel 2024-01-26 23:26:53 +01:00
parent c929d42ebd
commit a42ccb0faa
1 changed files with 116 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

162
src/Auth/LDAP.hs
View File

@ -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 -- SPDX-License-Identifier: AGPL-3.0-or-later
@ -9,9 +9,9 @@ module Auth.LDAP
, ADError(..), ADInvalidCredentials(..) , ADError(..), ADInvalidCredentials(..)
, campusLogin , campusLogin
, CampusUserException(..) , CampusUserException(..)
, campusUser, campusUser', campusUser'' , ldapUser, ldapUser', ldapUser''
, campusUserReTest, campusUserReTest' , ldapUserReTest, ldapUserReTest'
, campusUserMatr, campusUserMatr' , ldapUserMatr, ldapUserMatr'
, CampusMessage(..) , CampusMessage(..)
, ldapPrimaryKey , ldapPrimaryKey
, ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName , ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
@ -24,20 +24,25 @@ module Auth.LDAP
import Import.NoFoundation import Import.NoFoundation
import qualified Data.CaseInsensitive as CI import Auth.LDAP.AD
import Utils.Metrics
import Utils.Form
import qualified Ldap.Client as Ldap 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 Data.Text.Encoding as Text
import qualified Yesod.Auth.Message as Msg 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 deriving newtype instance Ord Ldap.Attr
@ -53,7 +58,11 @@ data CampusMessage = MsgCampusIdentPlaceholder
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) 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 findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase $ userSearchSettings conf) retAttrs) userFilters
where where
userFilters = userFilters =
@ -69,14 +78,19 @@ findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM
[ ldapUserFraportPersonalnummer Ldap.:= Text.encodeUtf8 ident [ 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 findUserMatr conf@LdapConf{..} ldap userMatr retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase $ userSearchSettings conf) retAttrs) userFilters
where where
userFilters = userFilters =
[ ldapUserFraportPersonalnummer Ldap.:= Text.encodeUtf8 userMatr [ ldapUserFraportPersonalnummer Ldap.:= Text.encodeUtf8 userMatr
] ]
userSearchSettings :: LdapConf -> Ldap.Mod Ldap.Search userSearchSettings :: LdapConf
-> Ldap.Mod Ldap.Search
userSearchSettings LdapConf{..} = mconcat userSearchSettings LdapConf{..} = mconcat
[ Ldap.scope ldapScope [ Ldap.scope ldapScope
, Ldap.size 2 , Ldap.size 2
@ -104,6 +118,7 @@ ldapUserEmail = Ldap.Attr "mail" :|
] ]
-- TODO: rename
data CampusUserException = CampusUserLdapError LdapPoolError data CampusUserException = CampusUserLdapError LdapPoolError
| CampusUserNoResult | CampusUserNoResult
| CampusUserAmbiguous | CampusUserAmbiguous
@ -113,20 +128,21 @@ instance Exception CampusUserException
makePrisms ''CampusUserException makePrisms ''CampusUserException
campusUserWith :: ( MonadUnliftIO m
, MonadCatch m ldapUserWith :: ( MonadUnliftIO m
) , MonadCatch m
=> ( Lens (LdapConf, LdapPool) (LdapConf, Ldap) LdapPool Ldap )
=> ( Lens (LdapConf, LdapPool) (LdapConf, Ldap) LdapPool Ldap
-> Failover (LdapConf, LdapPool) -> Failover (LdapConf, LdapPool)
-> FailoverMode -> FailoverMode
-> ((LdapConf, Ldap) -> m (Either CampusUserException (Ldap.AttrList []))) -> ((LdapConf, Ldap) -> m (Either CampusUserException (Ldap.AttrList [])))
-> m (Either LdapPoolError (Either CampusUserException (Ldap.AttrList []))) -> m (Either LdapPoolError (Either CampusUserException (Ldap.AttrList [])))
) )
-> Failover (LdapConf, LdapPool) -> Failover (LdapConf, LdapPool)
-> FailoverMode -> FailoverMode
-> Creds site -> Creds site
-> m (Either CampusUserException (Ldap.AttrList [])) -> m (Either CampusUserException (Ldap.AttrList []))
campusUserWith withLdap' pool mode Creds{..} = either (throwM . CampusUserLdapError) return <=< withLdap' _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO . runExceptT $ do 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 lift $ Ldap.bind ldap ldapDn ldapPassword
results <- case lookup "DN" credsExtra of results <- case lookup "DN" credsExtra of
Just userDN -> do Just userDN -> do
@ -139,28 +155,74 @@ campusUserWith withLdap' pool mode Creds{..} = either (throwM . CampusUserLdapEr
[Ldap.SearchEntry _ attrs] -> return attrs [Ldap.SearchEntry _ attrs] -> return attrs
_otherwise -> throwE CampusUserAmbiguous _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 [])) ldapUserReTest :: ( MonadUnliftIO m
campusUserReTest' pool doTest mode User{userIdent,userLdapPrimaryKey} , MonadMask m
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUserReTest pool doTest mode (Creds apLdap upsertIdent []) , 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 where upsertIdent = fromMaybe (CI.original userIdent) userLdapPrimaryKey
campusUser :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> Creds site -> m (Ldap.AttrList []) ldapUser :: ( MonadMask m
campusUser pool mode creds = throwLeft =<< campusUserWith withLdapFailover pool mode creds , 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 [])) ldapUser' :: ( MonadMask m
campusUser' pool mode User{userIdent} , MonadUnliftIO m
= campusUser'' pool mode $ CI.original userIdent , 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 [])) ldapUser'' :: ( MonadMask m
campusUser'' pool mode ident , MonadUnliftIO m
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser pool mode (Creds apLdap ident []) , 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 Ldap.bind ldap ldapDn ldapPassword
results <- findUserMatr conf ldap userMatr [] results <- findUserMatr conf ldap userMatr []
case results of case results of
@ -168,10 +230,16 @@ campusUserMatr pool mode userMatr = either (throwM . CampusUserLdapError) return
[Ldap.SearchEntry _ attrs] -> return attrs [Ldap.SearchEntry _ attrs] -> return attrs
_otherwise -> throwM CampusUserAmbiguous _otherwise -> throwM CampusUserAmbiguous
campusUserMatr' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Maybe (Ldap.AttrList [])) ldapUserMatr' :: ( MonadMask m
campusUserMatr' pool mode , MonadUnliftIO m
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . campusUserMatr pool mode , 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 newtype ADInvalidCredentials = ADInvalidCredentials ADError
@ -186,15 +254,14 @@ campusForm :: ( RenderMessage (HandlerSite m) FormMessage
, RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m)) , RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m))
, RenderMessage (HandlerSite m) CampusMessage , RenderMessage (HandlerSite m) CampusMessage
, MonadHandler m , MonadHandler m
) => WForm m (FormResult CampusLogin) )
=> WForm m (FormResult CampusLogin)
campusForm = do campusForm = do
MsgRenderer mr <- getMsgRenderer MsgRenderer mr <- getMsgRenderer
aFormToWForm $ CampusLogin aFormToWForm $ CampusLogin
<$> areq ciField (fslpI MsgCampusIdent (mr MsgCampusIdentPlaceholder) & addAttr "autofocus" "" & addAttr "autocomplete" "username") Nothing <$> areq ciField (fslpI MsgCampusIdent (mr MsgCampusIdentPlaceholder) & addAttr "autofocus" "" & addAttr "autocomplete" "username") Nothing
<*> areq passwordField (fslpI MsgCampusPassword (mr MsgCampusPasswordPlaceholder) & addAttr "autocomplete" "current-password") Nothing <*> areq passwordField (fslpI MsgCampusPassword (mr MsgCampusPasswordPlaceholder) & addAttr "autocomplete" "current-password") Nothing
apLdap :: Text
apLdap = "LDAP"
campusLogin :: forall site. campusLogin :: forall site.
( YesodAuth site ( YesodAuth site
@ -203,7 +270,10 @@ campusLogin :: forall site.
, RenderMessage site (ValueRequired site) , RenderMessage site (ValueRequired site)
, RenderMessage site ADInvalidCredentials , RenderMessage site ADInvalidCredentials
, Button site ButtonSubmit , Button site ButtonSubmit
) => Failover (LdapConf, LdapPool) -> FailoverMode -> AuthPlugin site )
=> Failover (LdapConf, LdapPool)
-> FailoverMode
-> AuthPlugin site
campusLogin pool mode = AuthPlugin{..} campusLogin pool mode = AuthPlugin{..}
where where
apName :: Text apName :: Text