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,132 +155,16 @@ upsertCampusUser :: forall m.
|
||||
=> UpsertCampusUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User)
|
||||
upsertCampusUser upsertMode ldapData = do
|
||||
now <- liftIO getCurrentTime
|
||||
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
|
||||
|
||||
let
|
||||
ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString
|
||||
ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null))
|
||||
|
||||
-- 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
|
||||
|
||||
-- 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)
|
||||
|
||||
-- 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)
|
||||
|
||||
-- just returns Nothing on error, pure
|
||||
decodeLdap :: Ldap.Attr -> Maybe Text
|
||||
decodeLdap attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapMap !!! attr
|
||||
|
||||
userTelephone = decodeLdap ldapUserTelephone
|
||||
userMobile = decodeLdap ldapUserMobile
|
||||
userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer
|
||||
userCompanyDepartment = decodeLdap ldapUserFraportAbteilung
|
||||
|
||||
userAuthentication
|
||||
| is _UpsertCampusUserLoginOther upsertMode
|
||||
= error "Non-LDAP logins should only work for users that are already known"
|
||||
| otherwise = AuthLDAP
|
||||
userLastAuthentication = guardOn isLogin now
|
||||
isLogin = has (_UpsertCampusUserLoginLdap <> _UpsertCampusUserLoginOther . united) upsertMode
|
||||
|
||||
userIdent <- if
|
||||
| [bs] <- ldapMap !!! ldapUserPrincipalName
|
||||
, Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
|
||||
, hasn't _upsertCampusUserIdent upsertMode || has (_upsertCampusUserIdent . only userIdent') upsertMode
|
||||
-> return userIdent'
|
||||
| Just userIdent' <- upsertMode ^? _upsertCampusUserIdent
|
||||
-> return userIdent'
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidIdent
|
||||
|
||||
userEmail <- if
|
||||
| userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail)
|
||||
-> return $ CI.mk userEmail
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidEmail
|
||||
userFirstName <- decodeLdapN ldapUserFirstName CampusUserInvalidGivenName
|
||||
userSurname <- decodeLdap1 ldapUserSurname CampusUserInvalidSurname
|
||||
userTitle <- decodeLdap' ldapUserTitle CampusUserInvalidTitle
|
||||
|
||||
userDisplayName' <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>=
|
||||
(maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
|
||||
|
||||
userLdapPrimaryKey <- if
|
||||
| [bs] <- ldapMap !!! ldapPrimaryKey
|
||||
, Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
|
||||
, Just userLdapPrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userLdapPrimaryKey''
|
||||
-> return $ Just userLdapPrimaryKey'''
|
||||
| otherwise
|
||||
-> return Nothing
|
||||
|
||||
let
|
||||
newUser = User
|
||||
{ userMaxFavourites = userDefaultMaxFavourites
|
||||
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
|
||||
, userTheme = userDefaultTheme
|
||||
, userDateTimeFormat = userDefaultDateTimeFormat
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
, userWarningDays = userDefaultWarningDays
|
||||
, userShowSex = userDefaultShowSex
|
||||
, userSex = Nothing
|
||||
, userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
|
||||
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
|
||||
, userNotificationSettings = def
|
||||
, userLanguages = Nothing
|
||||
, userCsvOptions = def
|
||||
, userTokensIssuedAfter = Nothing
|
||||
, userCreated = now
|
||||
, userLastLdapSynchronisation = Just now
|
||||
, userDisplayName = userDisplayName'
|
||||
, userDisplayEmail = userEmail
|
||||
, userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
|
||||
, userPostAddress = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
|
||||
, userPinPassword = Nothing -- must be derived via AVS
|
||||
, userPrefersPostal = False
|
||||
, ..
|
||||
}
|
||||
userUpdate = [
|
||||
-- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
|
||||
UserFirstName =. userFirstName
|
||||
, UserSurname =. userSurname
|
||||
, UserEmail =. userEmail
|
||||
, UserLastLdapSynchronisation =. Just now
|
||||
, UserLdapPrimaryKey =. userLdapPrimaryKey
|
||||
, UserMobile =. userMobile
|
||||
, UserTelephone =. userTelephone
|
||||
, UserCompanyPersonalNumber =. userCompanyPersonalNumber
|
||||
, UserCompanyDepartment =. userCompanyDepartment
|
||||
] ++
|
||||
[ UserLastAuthentication =. Just now | isLogin ]
|
||||
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 $ userDisplayName userRec) $
|
||||
update userId [ UserDisplayName =. userDisplayName' ]
|
||||
unless (validDisplayName userTitle userFirstName userSurname $ userRec ^. _userDisplayName) $
|
||||
update userId [ UserDisplayName =. userDisplayName ]
|
||||
|
||||
let
|
||||
userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
|
||||
@ -297,6 +182,136 @@ upsertCampusUser upsertMode ldapData = do
|
||||
|
||||
return user
|
||||
|
||||
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
|
||||
|
||||
|
||||
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
|
||||
userCompanyDepartment = decodeLdap ldapUserFraportAbteilung
|
||||
|
||||
userAuthentication
|
||||
| is _UpsertCampusUserLoginOther upsertMode
|
||||
= error "Non-LDAP logins should only work for users that are already known"
|
||||
| otherwise = AuthLDAP
|
||||
userLastAuthentication = guardOn isLogin now
|
||||
isLogin = has (_UpsertCampusUserLoginLdap <> _UpsertCampusUserLoginOther . united) upsertMode
|
||||
|
||||
userIdent <- if
|
||||
| [bs] <- ldapMap !!! ldapUserPrincipalName
|
||||
, Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
|
||||
, hasn't _upsertCampusUserIdent upsertMode || has (_upsertCampusUserIdent . only userIdent') upsertMode
|
||||
-> return userIdent'
|
||||
| Just userIdent' <- upsertMode ^? _upsertCampusUserIdent
|
||||
-> return userIdent'
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidIdent
|
||||
|
||||
userEmail <- if
|
||||
| userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail)
|
||||
-> return $ CI.mk userEmail
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidEmail
|
||||
userFirstName <- decodeLdapN ldapUserFirstName CampusUserInvalidGivenName
|
||||
userSurname <- decodeLdap1 ldapUserSurname CampusUserInvalidSurname
|
||||
userTitle <- decodeLdap' ldapUserTitle CampusUserInvalidTitle
|
||||
|
||||
userDisplayName' <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>=
|
||||
(maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
|
||||
|
||||
userLdapPrimaryKey <- if
|
||||
| [bs] <- ldapMap !!! ldapPrimaryKey
|
||||
, Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
|
||||
, Just userLdapPrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userLdapPrimaryKey''
|
||||
-> return $ Just userLdapPrimaryKey'''
|
||||
| otherwise
|
||||
-> return Nothing
|
||||
|
||||
let
|
||||
newUser = User
|
||||
{ userMaxFavourites = userDefaultMaxFavourites
|
||||
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
|
||||
, userTheme = userDefaultTheme
|
||||
, userDateTimeFormat = userDefaultDateTimeFormat
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
, userWarningDays = userDefaultWarningDays
|
||||
, userShowSex = userDefaultShowSex
|
||||
, userSex = Nothing
|
||||
, userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
|
||||
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
|
||||
, userNotificationSettings = def
|
||||
, userLanguages = Nothing
|
||||
, userCsvOptions = def
|
||||
, userTokensIssuedAfter = Nothing
|
||||
, userCreated = now
|
||||
, userLastLdapSynchronisation = Just now
|
||||
, userDisplayName = userDisplayName'
|
||||
, userDisplayEmail = userEmail
|
||||
, userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
|
||||
, userPostAddress = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
|
||||
, userPinPassword = Nothing -- must be derived via AVS
|
||||
, userPrefersPostal = False
|
||||
, ..
|
||||
}
|
||||
userUpdate = [
|
||||
-- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
|
||||
UserFirstName =. userFirstName
|
||||
, UserSurname =. userSurname
|
||||
, UserEmail =. userEmail
|
||||
, UserLastLdapSynchronisation =. Just now
|
||||
, UserLdapPrimaryKey =. userLdapPrimaryKey
|
||||
, UserMobile =. userMobile
|
||||
, UserTelephone =. userTelephone
|
||||
, UserCompanyPersonalNumber =. userCompanyPersonalNumber
|
||||
, UserCompanyDepartment =. userCompanyDepartment
|
||||
] ++
|
||||
[ UserLastAuthentication =. Just now | isLogin ]
|
||||
return (newUser, userUpdate)
|
||||
|
||||
where
|
||||
ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString
|
||||
ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null))
|
||||
|
||||
-- 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
|
||||
|
||||
-- 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)
|
||||
|
||||
-- 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)
|
||||
|
||||
-- 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
|
||||
sfs <- selectList [StudyFeaturesUser ==. uid] []
|
||||
|
||||
@ -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
|
||||
|
||||
@ -47,13 +49,18 @@ postAdminLdapR = do
|
||||
((presult, pwidget), penctype) <- runFormPost $ makeLdapPersonForm Nothing
|
||||
|
||||
let procFormPerson :: LdapQueryPerson -> Handler (Maybe (Ldap.AttrList []))
|
||||
procFormPerson LdapQueryPerson{..} = do
|
||||
ldapPool' <- getsYesod $ view _appLdapPool
|
||||
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
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user