chore(ldap): add ldap parsing test to ldap admin route
This commit is contained in:
Steffen Jost
parent
bb093b1221
commit
ce277af443
@ -106,7 +106,7 @@ PWHashLoginTitle: FRADrive Login
|
||||
PWHashLoginNote: Verwenden Sie dieses Formular für zugesandte FRADrive Logindaten. Angestellte der Fraport AG sollten stattdessen den Büko-Login verwenden!
|
||||
DummyLoginTitle: Development-Login
|
||||
InternalLdapError: Interner Fehler beim Fraport Büko-Login
|
||||
CampusUserInvalidIdent: Konnte anhand des Fraport Büko-Logins keine eindeutige Identifikation
|
||||
CampusUserInvalidIdent: Konnte anhand des Fraport Büko-Logins keine eindeutige Identifikation ermitteln
|
||||
CampusUserInvalidEmail: Konnte anhand des Fraport Büko-Logins keine E-Mail-Addresse ermitteln
|
||||
CampusUserInvalidDisplayName: Konnte anhand des Fraport Büko-Logins keinen vollen Namen ermitteln
|
||||
CampusUserInvalidGivenName: Konnte anhand des Fraport Büko-Logins keinen Vornamen ermitteln
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
module Foundation.Yesod.Auth
|
||||
( authenticate
|
||||
, upsertCampusUser
|
||||
, decodeUserTest
|
||||
, CampusUserConversionException(..)
|
||||
, campusUserFailoverMode, updateUserLanguage
|
||||
) where
|
||||
@ -154,41 +155,45 @@ upsertCampusUser :: forall m.
|
||||
=> UpsertCampusUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User)
|
||||
upsertCampusUser upsertMode ldapData = do
|
||||
now <- liftIO getCurrentTime
|
||||
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
|
||||
userDefaultConf <- getsYesod $ view _appUserDefaults
|
||||
|
||||
(newUser@User{..},userUpdate) <- decodeUser now userDefaultConf upsertMode ldapData
|
||||
oldUsers <- for userLdapPrimaryKey $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] []
|
||||
|
||||
user@(Entity userId userRec) <- case oldUsers of
|
||||
Just [oldUserId] -> updateGetEntity oldUserId userUpdate
|
||||
_other -> upsertBy (UniqueAuthentication userIdent) newUser userUpdate
|
||||
unless (validDisplayName userTitle userFirstName userSurname $ userRec ^. _userDisplayName) $
|
||||
update userId [ UserDisplayName =. userDisplayName ]
|
||||
|
||||
let
|
||||
ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString
|
||||
ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null))
|
||||
userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
|
||||
userSystemFunctions' = do
|
||||
(k, v) <- ldapData
|
||||
guard $ k == ldapAffiliation
|
||||
v' <- v
|
||||
Right str <- return $ Text.decodeUtf8' v'
|
||||
assertM' (not . Text.null) $ Text.strip str
|
||||
|
||||
-- only accept a single result, throw error otherwise
|
||||
-- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text
|
||||
decodeLdap1 attr err
|
||||
| [bs] <- ldapMap !!! attr
|
||||
, Right t <- Text.decodeUtf8' bs
|
||||
= return t
|
||||
| otherwise = throwM err
|
||||
iforM_ userSystemFunctions $ \func preset -> do
|
||||
memcachedByInvalidate (AuthCacheSystemFunctionList func) $ Proxy @(Set UserId)
|
||||
if | preset -> void $ upsert (UserSystemFunction userId func False False) []
|
||||
| otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
|
||||
|
||||
-- accept multiple successful decodings, ignoring all others
|
||||
decodeLdapN attr err
|
||||
| t@(_:_) <- rights vs
|
||||
= return $ Text.unwords t
|
||||
| otherwise = throwM err
|
||||
where
|
||||
vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
|
||||
return user
|
||||
|
||||
-- accept any successful decoding or empty; only throw an error if all decodings fail
|
||||
-- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m Text
|
||||
decodeLdap' attr err
|
||||
| [] <- vs = return Nothing
|
||||
| (h:_) <- rights vs = return $ Just h
|
||||
| otherwise = throwM err
|
||||
where
|
||||
vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
|
||||
decodeUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m)
|
||||
=> Maybe UserIdent -> Ldap.AttrList [] -> m (Either CampusUserConversionException (User, [Update User]))
|
||||
decodeUserTest mbIdent ldapData = do
|
||||
now <- liftIO getCurrentTime
|
||||
userDefaultConf <- getsYesod $ view _appUserDefaults
|
||||
let mode = maybe UpsertCampusUserLoginLdap UpsertCampusUserLoginDummy mbIdent
|
||||
try $ decodeUser now userDefaultConf mode ldapData
|
||||
|
||||
-- just returns Nothing on error, pure
|
||||
decodeLdap :: Ldap.Attr -> Maybe Text
|
||||
decodeLdap attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapMap !!! attr
|
||||
|
||||
decodeUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertCampusUserMode -> Ldap.AttrList [] -> m (User,_)
|
||||
decodeUser now UserDefaultConf{..} upsertMode ldapData = do
|
||||
let
|
||||
userTelephone = decodeLdap ldapUserTelephone
|
||||
userMobile = decodeLdap ldapUserMobile
|
||||
userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer
|
||||
@ -272,30 +277,40 @@ upsertCampusUser upsertMode ldapData = do
|
||||
, UserCompanyDepartment =. userCompanyDepartment
|
||||
] ++
|
||||
[ UserLastAuthentication =. Just now | isLogin ]
|
||||
return (newUser, userUpdate)
|
||||
|
||||
oldUsers <- for userLdapPrimaryKey $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] []
|
||||
where
|
||||
ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString
|
||||
ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null))
|
||||
|
||||
user@(Entity userId userRec) <- case oldUsers of
|
||||
Just [oldUserId] -> updateGetEntity oldUserId userUpdate
|
||||
_other -> upsertBy (UniqueAuthentication userIdent) newUser userUpdate
|
||||
unless (validDisplayName userTitle userFirstName userSurname $ userDisplayName userRec) $
|
||||
update userId [ UserDisplayName =. userDisplayName' ]
|
||||
-- only accept a single result, throw error otherwise
|
||||
-- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text
|
||||
decodeLdap1 attr err
|
||||
| [bs] <- ldapMap !!! attr
|
||||
, Right t <- Text.decodeUtf8' bs
|
||||
= return t
|
||||
| otherwise = throwM err
|
||||
|
||||
let
|
||||
userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
|
||||
userSystemFunctions' = do
|
||||
(k, v) <- ldapData
|
||||
guard $ k == ldapAffiliation
|
||||
v' <- v
|
||||
Right str <- return $ Text.decodeUtf8' v'
|
||||
assertM' (not . Text.null) $ Text.strip str
|
||||
-- accept multiple successful decodings, ignoring all others
|
||||
decodeLdapN attr err
|
||||
| t@(_:_) <- rights vs
|
||||
= return $ Text.unwords t
|
||||
| otherwise = throwM err
|
||||
where
|
||||
vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
|
||||
|
||||
iforM_ userSystemFunctions $ \func preset -> do
|
||||
memcachedByInvalidate (AuthCacheSystemFunctionList func) $ Proxy @(Set UserId)
|
||||
if | preset -> void $ upsert (UserSystemFunction userId func False False) []
|
||||
| otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
|
||||
-- accept any successful decoding or empty; only throw an error if all decodings fail
|
||||
-- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m Text
|
||||
decodeLdap' attr err
|
||||
| [] <- vs = return Nothing
|
||||
| (h:_) <- rights vs = return $ Just h
|
||||
| otherwise = throwM err
|
||||
where
|
||||
vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
|
||||
|
||||
return user
|
||||
-- just returns Nothing on error, pure
|
||||
decodeLdap :: Ldap.Attr -> Maybe Text
|
||||
decodeLdap attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapMap !!! attr
|
||||
|
||||
associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m ()
|
||||
associateUserSchoolsByTerms uid = do
|
||||
|
||||
@ -8,9 +8,11 @@ module Handler.Admin.Ldap
|
||||
import Import
|
||||
-- import qualified Control.Monad.State.Class as State
|
||||
-- import Data.Aeson (encode)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
-- import qualified Data.Text as Text
|
||||
import qualified Data.Text.Encoding as Text
|
||||
-- import qualified Data.Set as Set
|
||||
import Foundation.Yesod.Auth (decodeUserTest)
|
||||
|
||||
import Handler.Utils
|
||||
|
||||
@ -49,11 +51,16 @@ postAdminLdapR = do
|
||||
let procFormPerson :: LdapQueryPerson -> Handler (Maybe (Ldap.AttrList []))
|
||||
procFormPerson LdapQueryPerson{..} = do
|
||||
ldapPool' <- getsYesod $ view _appLdapPool
|
||||
|
||||
if isNothing ldapPool'
|
||||
then addMessage Warning $ text2Html "LDAP Configuration missing."
|
||||
else addMessage Info $ text2Html "Input for LDAP test received."
|
||||
fmap join . for ldapPool' $ \ldapPool ->
|
||||
campusUser'' ldapPool FailoverUnlimited ldapQueryIdent
|
||||
fmap join . for ldapPool' $ \ldapPool -> do
|
||||
ldapData <- campusUser'' ldapPool FailoverUnlimited ldapQueryIdent
|
||||
eitherErr <- decodeUserTest (Just $ CI.mk ldapQueryIdent) $ concat ldapData
|
||||
whenIsLeft eitherErr $ addMessageI Error
|
||||
return ldapData
|
||||
|
||||
|
||||
mbLdapData <- formResultMaybe presult procFormPerson
|
||||
|
||||
|
||||
Reference in New Issue
Block a user