diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 8ad8c2aab..c8650bc44 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -8,7 +8,7 @@ module Auth.LDAP ( apLdap , ADError(..), ADInvalidCredentials(..) , ldapLogin - , CampusUserException(..) + , LdapUserException(..) , ldapUser, ldapUser', ldapUser'' --, ldapUserReTest, ldapUserReTest' , ldapUserMatr, ldapUserMatr' @@ -46,11 +46,13 @@ apLdap = "LDAP" deriving newtype instance Ord Ldap.Attr +-- TODO: rename data CampusLogin = CampusLogin { campusIdent :: CI Text , campusPassword :: Text } deriving (Generic) +-- TODO: rename data CampusMessage = MsgCampusIdentPlaceholder | MsgCampusIdent | MsgCampusPassword @@ -118,15 +120,14 @@ ldapUserEmail = Ldap.Attr "mail" :| ] --- TODO: rename -data CampusUserException = CampusUserLdapError LdapPoolError - | CampusUserNoResult - | CampusUserAmbiguous +data LdapUserException = LdapUserLdapError LdapPoolError + | LdapUserNoResult + | LdapUserAmbiguous deriving (Show, Eq, Generic) -instance Exception CampusUserException +instance Exception LdapUserException -makePrisms ''CampusUserException +makePrisms ''LdapUserException ldapUserWith :: ( MonadUnliftIO m @@ -139,13 +140,13 @@ ldapUserWith :: ( MonadUnliftIO m -- -> m (Either LdapPoolError (Either CampusUserException (Ldap.AttrList []))) -- ) => ( LdapPool - -> (Ldap -> m (Either CampusUserException (Ldap.AttrList []))) - -> m (Either LdapPoolError (Either CampusUserException (Ldap.AttrList []))) + -> (Ldap -> m (Either LdapUserException (Ldap.AttrList []))) + -> m (Either LdapPoolError (Either LdapUserException (Ldap.AttrList []))) ) -> (LdapConf, LdapPool) -> Creds site - -> m (Either CampusUserException (Ldap.AttrList [])) -ldapUserWith withLdap' (conf@LdapConf{..}, pool) Creds{..} = either (throwM . CampusUserLdapError) return <=< withLdap' pool $ \ldap -> liftIO . runExceptT $ do + -> m (Either LdapUserException (Ldap.AttrList [])) +ldapUserWith withLdap' (conf@LdapConf{..}, pool) Creds{..} = either (throwM . LdapUserLdapError) return <=< withLdap' pool $ \ldap -> liftIO . runExceptT $ do lift $ Ldap.bind ldap ldapDn ldapPassword results <- case lookup "DN" credsExtra of Just userDN -> do @@ -154,9 +155,9 @@ ldapUserWith withLdap' (conf@LdapConf{..}, pool) Creds{..} = either (throwM . Ca Nothing -> do lift $ findUser conf ldap credsIdent [] case results of - [] -> throwE CampusUserNoResult + [] -> throwE LdapUserNoResult [Ldap.SearchEntry _ attrs] -> return attrs - _otherwise -> throwE CampusUserAmbiguous + _otherwise -> throwE LdapUserAmbiguous -- TODO: reintroduce once failover has been reimplemented @@ -212,7 +213,7 @@ ldapUser'' :: ( MonadMask m -> Text -> m (Maybe (Ldap.AttrList [])) ldapUser'' pool ident - = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ ldapUser pool (Creds apLdap ident []) + = runMaybeT . catchIfMaybeT (is _LdapUserNoResult) $ ldapUser pool (Creds apLdap ident []) ldapUserMatr :: ( MonadUnliftIO m @@ -222,13 +223,13 @@ ldapUserMatr :: ( MonadUnliftIO m => (LdapConf, LdapPool) -> UserMatriculation -> m (Ldap.AttrList []) -ldapUserMatr (conf@LdapConf{..}, pool) userMatr = either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> liftIO $ do +ldapUserMatr (conf@LdapConf{..}, pool) userMatr = either (throwM . LdapUserLdapError) return <=< withLdap pool $ \ldap -> liftIO $ do Ldap.bind ldap ldapDn ldapPassword results <- findUserMatr conf ldap userMatr [] case results of - [] -> throwM CampusUserNoResult + [] -> throwM LdapUserNoResult [Ldap.SearchEntry _ attrs] -> return attrs - _otherwise -> throwM CampusUserAmbiguous + _otherwise -> throwM LdapUserAmbiguous ldapUserMatr' :: ( MonadMask m , MonadUnliftIO m @@ -237,7 +238,7 @@ ldapUserMatr' :: ( MonadMask m => (LdapConf, LdapPool) -> UserMatriculation -> m (Maybe (Ldap.AttrList [])) -ldapUserMatr' pool = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . ldapUserMatr pool +ldapUserMatr' pool = runMaybeT . catchIfMaybeT (is _LdapUserNoResult) . ldapUserMatr pool newtype ADInvalidCredentials = ADInvalidCredentials ADError