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

chore(ldap): add ldap parsing test to ldap admin route

Browse Source
This commit is contained in:
Steffen Jost 2022-09-14 16:00:18 +02:00
parent bb093b1221
commit ce277af443
3 changed files with 147 additions and 125 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
messages/uniworx/categories/authorization/de-de-formal.msg
View File

@ -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! PWHashLoginNote: Verwenden Sie dieses Formular für zugesandte FRADrive Logindaten. Angestellte der Fraport AG sollten stattdessen den Büko-Login verwenden!
DummyLoginTitle: Development-Login DummyLoginTitle: Development-Login
InternalLdapError: Interner Fehler beim Fraport Büko-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 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 CampusUserInvalidDisplayName: Konnte anhand des Fraport Büko-Logins keinen vollen Namen ermitteln
CampusUserInvalidGivenName: Konnte anhand des Fraport Büko-Logins keinen Vornamen ermitteln CampusUserInvalidGivenName: Konnte anhand des Fraport Büko-Logins keinen Vornamen ermitteln

255
src/Foundation/Yesod/Auth.hs
View File

@ -1,6 +1,7 @@
module Foundation.Yesod.Auth module Foundation.Yesod.Auth
( authenticate ( authenticate
, upsertCampusUser , upsertCampusUser
, decodeUserTest
, CampusUserConversionException(..) , CampusUserConversionException(..)
, campusUserFailoverMode, updateUserLanguage , campusUserFailoverMode, updateUserLanguage
) where ) where
@ -154,132 +155,16 @@ upsertCampusUser :: forall m.
=> UpsertCampusUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User) => UpsertCampusUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User)
upsertCampusUser upsertMode ldapData = do upsertCampusUser upsertMode ldapData = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults 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 ]
(newUser@User{..},userUpdate) <- decodeUser now userDefaultConf upsertMode ldapData
oldUsers <- for userLdapPrimaryKey $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] [] oldUsers <- for userLdapPrimaryKey $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] []
user@(Entity userId userRec) <- case oldUsers of user@(Entity userId userRec) <- case oldUsers of
Just [oldUserId] -> updateGetEntity oldUserId userUpdate Just [oldUserId] -> updateGetEntity oldUserId userUpdate
_other -> upsertBy (UniqueAuthentication userIdent) newUser userUpdate _other -> upsertBy (UniqueAuthentication userIdent) newUser userUpdate
unless (validDisplayName userTitle userFirstName userSurname $ userDisplayName userRec) $ unless (validDisplayName userTitle userFirstName userSurname $ userRec ^. _userDisplayName) $
update userId [ UserDisplayName =. userDisplayName' ] update userId [ UserDisplayName =. userDisplayName ]
let let
userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions' userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
@ -297,6 +182,136 @@ upsertCampusUser upsertMode ldapData = do
return user 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 :: MonadIO m => UserId -> SqlPersistT m ()
associateUserSchoolsByTerms uid = do associateUserSchoolsByTerms uid = do
sfs <- selectList [StudyFeaturesUser ==. uid] [] sfs <- selectList [StudyFeaturesUser ==. uid] []

15
src/Handler/Admin/Ldap.hs
View File

@ -8,9 +8,11 @@ module Handler.Admin.Ldap
import Import import Import
-- import qualified Control.Monad.State.Class as State -- import qualified Control.Monad.State.Class as State
-- import Data.Aeson (encode) -- import Data.Aeson (encode)
import qualified Data.CaseInsensitive as CI
-- import qualified Data.Text as Text -- import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text import qualified Data.Text.Encoding as Text
-- import qualified Data.Set as Set -- import qualified Data.Set as Set
import Foundation.Yesod.Auth (decodeUserTest)
import Handler.Utils import Handler.Utils
@ -47,13 +49,18 @@ postAdminLdapR = do
((presult, pwidget), penctype) <- runFormPost $ makeLdapPersonForm Nothing ((presult, pwidget), penctype) <- runFormPost $ makeLdapPersonForm Nothing
let procFormPerson :: LdapQueryPerson -> Handler (Maybe (Ldap.AttrList [])) let procFormPerson :: LdapQueryPerson -> Handler (Maybe (Ldap.AttrList []))
procFormPerson LdapQueryPerson{..} = do procFormPerson LdapQueryPerson{..} = do
ldapPool' <- getsYesod $ view _appLdapPool ldapPool' <- getsYesod $ view _appLdapPool
if isNothing ldapPool' if isNothing ldapPool'
then addMessage Warning $ text2Html "LDAP Configuration missing." then addMessage Warning $ text2Html "LDAP Configuration missing."
else addMessage Info $ text2Html "Input for LDAP test received." else addMessage Info $ text2Html "Input for LDAP test received."
fmap join . for ldapPool' $ \ldapPool -> fmap join . for ldapPool' $ \ldapPool -> do
campusUser'' ldapPool FailoverUnlimited ldapQueryIdent ldapData <- campusUser'' ldapPool FailoverUnlimited ldapQueryIdent
eitherErr <- decodeUserTest (Just $ CI.mk ldapQueryIdent) $ concat ldapData
whenIsLeft eitherErr $ addMessageI Error
return ldapData
mbLdapData <- formResultMaybe presult procFormPerson mbLdapData <- formResultMaybe presult procFormPerson