diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 329bb0a29..f3e690e85 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Felix Hamann , Gregor Kleen , Sarah Vaupel , Steffen Jost , Steffen Jost -- -- 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