refactor(ldap): git merge problem
This commit is contained in:
Steffen Jost
parent
d3314b3e36
commit
a804c98520
@ -1,3 +1,5 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Auth.LDAP
|
||||
( apLdap
|
||||
, ADError(..), ADInvalidCredentials(..)
|
||||
@ -13,6 +15,7 @@ module Auth.LDAP
|
||||
, ldapAffiliation
|
||||
, ldapUserMobile, ldapUserTelephone
|
||||
, ldapUserFraportPersonalnummer, ldapUserFraportAbteilung
|
||||
, ldapUserTitle
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
@ -30,6 +33,9 @@ import qualified Yesod.Auth.Message as Msg
|
||||
|
||||
import Auth.LDAP.AD
|
||||
|
||||
-- allow Ldap.Attr usage as key for Data.Map
|
||||
deriving newtype instance Ord Ldap.Attr
|
||||
|
||||
|
||||
data CampusLogin = CampusLogin
|
||||
{ campusIdent :: CI Text
|
||||
@ -72,29 +78,20 @@ userSearchSettings LdapConf{..} = mconcat
|
||||
, Ldap.derefAliases Ldap.DerefAlways
|
||||
]
|
||||
|
||||
ldapPrimaryKey, ldapUserPrincipalName, ldapUserDisplayName, ldapUserFirstName, ldapUserSurname, ldapAffiliation, ldapUserMobile, ldapUserTelephone, ldapUserFraportPersonalnummer, ldapUserFraportAbteilung :: Ldap.Attr
|
||||
ldapPrimaryKey, ldapUserPrincipalName, ldapUserDisplayName, ldapUserFirstName, ldapUserSurname, ldapAffiliation, ldapUserTitle, ldapUserTelephone, ldapUserMobile, ldapUserFraportPersonalnummer, ldapUserFraportAbteilung :: Ldap.Attr
|
||||
ldapPrimaryKey = Ldap.Attr "cn" -- should always be identical to "sAMAccountName"
|
||||
ldapUserPrincipalName = Ldap.Attr "userPrincipalName"
|
||||
ldapUserDisplayName = Ldap.Attr "displayName"
|
||||
ldapUserFirstName = Ldap.Attr "givenName"
|
||||
ldapUserSurname = Ldap.Attr "sn"
|
||||
ldapAffiliation = Ldap.Attr "memberOf" -- group determine user functions, see Handler.Utils.LdapSystemFunctions.determineSystemFunctions
|
||||
ldapUserTitle = Ldap.Attr "title" -- not used at Fraport
|
||||
-- new
|
||||
ldapUserTelephone = Ldap.Attr "telephoneNumber"
|
||||
ldapUserMobile = Ldap.Attr "mobile"
|
||||
ldapUserFraportPersonalnummer = Ldap.Attr "sAMAccountName"
|
||||
ldapUserFraportAbteilung = Ldap.Attr "department"
|
||||
|
||||
{- --outdated to be removed
|
||||
ldapUserMatriculation = Ldap.Attr "LMU-Stud-Matrikelnummer"
|
||||
ldapUserTitle = Ldap.Attr "title"
|
||||
ldapUserStudyFeatures = Ldap.Attr "dfnEduPersonFeaturesOfStudy"
|
||||
ldapUserFieldName = Ldap.Attr "LMU-Stg-Fach"
|
||||
ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString"
|
||||
ldapSex = Ldap.Attr "schacGender"
|
||||
ldapUserSubTermsSemester = Ldap.Attr "LMU-Stg-FachundFS"
|
||||
-}
|
||||
|
||||
ldapUserEmail :: NonEmpty Ldap.Attr
|
||||
ldapUserEmail = Ldap.Attr "mail" :|
|
||||
[ Ldap.Attr "userPrincipalName"
|
||||
|
||||
@ -26,12 +26,13 @@ import qualified Control.Monad.Catch as C (Handler(..))
|
||||
import qualified Ldap.Client as Ldap
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Encoding as Text
|
||||
-- import qualified Data.ByteString as ByteString
|
||||
import qualified Data.ByteString as ByteString
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
-- import qualified Data.Conduit.Combinators as C
|
||||
|
||||
-- import qualified Data.List as List ((\\))
|
||||
|
||||
|
||||
-- import qualified Data.UUID as UUID
|
||||
-- import Data.ByteArray (convert)
|
||||
-- import Crypto.Hash (SHAKE128)
|
||||
@ -112,7 +113,7 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
|
||||
_other
|
||||
-> acceptExisting
|
||||
|
||||
|
||||
|
||||
data CampusUserConversionException
|
||||
= CampusUserInvalidIdent
|
||||
| CampusUserInvalidEmail
|
||||
@ -120,7 +121,7 @@ data CampusUserConversionException
|
||||
| CampusUserInvalidGivenName
|
||||
| CampusUserInvalidSurname
|
||||
| CampusUserInvalidTitle
|
||||
| CampusUserInvalidMatriculation
|
||||
| CampusUserInvalidMatriculation
|
||||
| CampusUserInvalidFeaturesOfStudy Text
|
||||
| CampusUserInvalidAssociatedSchools Text
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
@ -155,22 +156,30 @@ upsertCampusUser upsertMode ldapData = do
|
||||
now <- liftIO getCurrentTime
|
||||
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
|
||||
|
||||
let
|
||||
userEmail' = fold $ do
|
||||
k' <- toList ldapUserEmail
|
||||
(k, v) <- ldapData
|
||||
guard $ k' == k
|
||||
return v
|
||||
-- SJ says: this highly repetitive code needs fefactoring; why not turn ldapData into a Data.Map right away instead of repetitive list iteration?
|
||||
userLdapPrimaryKey' = fold [ v | (k, v) <- ldapData, k == ldapPrimaryKey ]
|
||||
userIdent'' = fold [ v | (k, v) <- ldapData, k == ldapUserPrincipalName ]
|
||||
userDisplayName'' = fold [ v | (k, v) <- ldapData, k == ldapUserDisplayName ]
|
||||
userFirstName' = fold [ v | (k, v) <- ldapData, k == ldapUserFirstName ]
|
||||
userSurname' = fold [ v | (k, v) <- ldapData, k == ldapUserSurname ]
|
||||
userTelephone' = fold [ v | (k, v) <- ldapData, k == ldapUserTelephone ]
|
||||
userMobile' = fold [ v | (k, v) <- ldapData, k == ldapUserMobile ]
|
||||
userFraportPersonalnummer' = fold [ v | (k, v) <- ldapData, k == ldapUserFraportPersonalnummer ]
|
||||
userFraportAbteilung' = fold [ v | (k, v) <- ldapData, k == ldapUserFraportAbteilung ]
|
||||
let
|
||||
ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue]
|
||||
ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null))
|
||||
userEmail' :: [Ldap.AttrValue]
|
||||
userEmail' = lookupSome ldapMap $ toList ldapUserEmail
|
||||
userLdapPrimaryKey' :: [Ldap.AttrValue] -- ~ [ByteString]
|
||||
userLdapPrimaryKey' = ldapMap !!! ldapPrimaryKey
|
||||
userIdent'' = ldapMap !!! ldapUserPrincipalName
|
||||
userDisplayName'' = ldapMap !!! ldapUserDisplayName
|
||||
-- userFirstName' = ldapMap !!! ldapUserFirstName
|
||||
userSurname' = ldapMap !!! ldapUserSurname
|
||||
userTitle' = ldapMap !!! ldapUserTitle
|
||||
userTelephone' = ldapMap !!! ldapUserTelephone
|
||||
userMobile' = ldapMap !!! ldapUserMobile
|
||||
userFraportPersonalnummer' = ldapMap !!! ldapUserFraportPersonalnummer
|
||||
userFraportAbteilung' = ldapMap !!! ldapUserFraportAbteilung
|
||||
|
||||
-- TODO: continue here
|
||||
decodeLdap1 :: _hole -- (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
|
||||
|
||||
userAuthentication
|
||||
| is _UpsertCampusUserLoginOther upsertMode
|
||||
@ -193,45 +202,55 @@ upsertCampusUser upsertMode ldapData = do
|
||||
-> return $ CI.mk userEmail
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidEmail
|
||||
userDisplayName' <- if
|
||||
| [bs] <- userDisplayName''
|
||||
, Right userDisplayName' <- Text.decodeUtf8' bs
|
||||
-> return userDisplayName'
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidDisplayName
|
||||
userFirstName <- if
|
||||
| [bs] <- userFirstName'
|
||||
, Right userFirstName <- Text.decodeUtf8' bs
|
||||
-> return userFirstName
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidGivenName
|
||||
userFirstName <- decodeLdap1 ldapUserFirstName CampusUserInvalidGivenName
|
||||
--userFirstName <- if
|
||||
-- | [bs] <- userFirstName'
|
||||
-- , Right userFirstName <- Text.decodeUtf8' bs
|
||||
-- -> return userFirstName
|
||||
-- | otherwise
|
||||
-- -> throwM CampusUserInvalidGivenName
|
||||
userSurname <- if
|
||||
| [bs] <- userSurname'
|
||||
, Right userSurname <- Text.decodeUtf8' bs
|
||||
-> return userSurname
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidSurname
|
||||
userTelephone <- if
|
||||
userTitle <- if
|
||||
| [] <- userTitle'
|
||||
-> return Nothing
|
||||
| [bs] <- userTitle'
|
||||
, Right userTitle <- Text.decodeUtf8' bs
|
||||
-> return $ Just userTitle
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidTitle
|
||||
userDisplayName' <- if
|
||||
| [bs] <- userDisplayName''
|
||||
, Right userDisplayName1 <- Text.decodeUtf8' bs
|
||||
, Just userDisplayName2 <- checkDisplayName userTitle userFirstName userSurname userDisplayName1
|
||||
-> return userDisplayName2
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidDisplayName
|
||||
userTelephone <- if
|
||||
| [bs] <- userTelephone'
|
||||
, Right userTelephone <- Text.decodeUtf8' bs
|
||||
, Right userTelephone <- Text.decodeUtf8' bs
|
||||
-> return $ Just userTelephone
|
||||
| otherwise
|
||||
-> return Nothing
|
||||
userMobile <- if
|
||||
userMobile <- if
|
||||
| [bs] <- userMobile'
|
||||
, Right userMobile <- Text.decodeUtf8' bs
|
||||
, Right userMobile <- Text.decodeUtf8' bs
|
||||
-> return $ Just userMobile
|
||||
| otherwise
|
||||
-> return Nothing
|
||||
userCompanyPersonalNumber <- if
|
||||
userCompanyPersonalNumber <- if
|
||||
| [bs] <- userFraportPersonalnummer'
|
||||
, Right dt <- Text.decodeUtf8' bs
|
||||
, Right dt <- Text.decodeUtf8' bs
|
||||
-> return $ Just dt
|
||||
| otherwise
|
||||
-> return Nothing
|
||||
userCompanyDepartment <- if
|
||||
userCompanyDepartment <- if
|
||||
| [bs] <- userFraportAbteilung'
|
||||
, Right dt <- Text.decodeUtf8' bs
|
||||
, Right dt <- Text.decodeUtf8' bs
|
||||
-> return $ Just dt
|
||||
| otherwise
|
||||
-> return Nothing
|
||||
@ -266,17 +285,16 @@ upsertCampusUser upsertMode ldapData = do
|
||||
, userLastLdapSynchronisation = Just now
|
||||
, userDisplayName = userDisplayName'
|
||||
, userDisplayEmail = userEmail
|
||||
, userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
|
||||
, userTitle = Nothing
|
||||
, 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
|
||||
, userPrefersPostal = False
|
||||
, ..
|
||||
}
|
||||
userUpdate = [
|
||||
userUpdate = [
|
||||
-- UserDisplayName =. userDisplayName -- never updated, since users are allowed to change their DisplayName
|
||||
UserFirstName =. userFirstName
|
||||
, UserSurname =. userSurname
|
||||
, UserEmail =. userEmail
|
||||
, UserSurname =. userSurname
|
||||
, UserEmail =. userEmail
|
||||
, UserLastLdapSynchronisation =. Just now
|
||||
, UserLdapPrimaryKey =. userLdapPrimaryKey
|
||||
, UserMobile =. userMobile
|
||||
@ -308,7 +326,7 @@ upsertCampusUser upsertMode ldapData = do
|
||||
if | preset -> void $ upsert (UserSystemFunction userId func False False) []
|
||||
| otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
|
||||
|
||||
return user
|
||||
return user
|
||||
|
||||
associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m ()
|
||||
associateUserSchoolsByTerms uid = do
|
||||
@ -322,7 +340,7 @@ associateUserSchoolsByTerms uid = do
|
||||
, userSchoolSchool = schoolTermsSchool
|
||||
, userSchoolIsOptOut = False
|
||||
}
|
||||
|
||||
|
||||
updateUserLanguage :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, YesodAuth UniWorX
|
||||
, UserId ~ AuthId UniWorX
|
||||
|
||||
@ -1,5 +1,7 @@
|
||||
module Handler.Utils.Profile
|
||||
( validDisplayName
|
||||
( checkDisplayName
|
||||
, validDisplayName
|
||||
, fixDisplayName
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
@ -8,7 +10,18 @@ import qualified Data.Text as Text
|
||||
import qualified Data.MultiSet as MultiSet
|
||||
import qualified Data.Set as Set
|
||||
|
||||
-- | remove last comma and swap order of the two parts, ie. transforming "surname, givennames" into "givennames surname".
|
||||
-- Input "givennames surname" is left unchanged, except for removing excess whitespace
|
||||
fixDisplayName :: UserDisplayName -> UserDisplayName
|
||||
fixDisplayName udn =
|
||||
let (Text.strip . Text.dropEnd 1 -> surname, Text.strip -> firstnames) = Text.breakOnEnd "," udn
|
||||
in Text.strip $ firstnames <> Text.cons ' ' surname
|
||||
|
||||
-- | Like `validDisplayName` but may return an automatically corrected name
|
||||
checkDisplayName :: Maybe UserTitle -> UserFirstName -> UserSurname -> UserDisplayName -> Maybe UserDisplayName
|
||||
checkDisplayName mTitle fName sName (fixDisplayName -> dName)
|
||||
| validDisplayName mTitle fName sName dName = Just dName
|
||||
| otherwise = Nothing
|
||||
|
||||
validDisplayName :: Maybe UserTitle
|
||||
-> UserFirstName
|
||||
@ -31,7 +44,7 @@ validDisplayName (fmap Text.strip -> mTitle) (Text.strip -> fName) (Text.strip -
|
||||
fNameLetters = Set.fromList $ unpack fName
|
||||
sNameLetters = Set.fromList $ unpack sName
|
||||
dNameLetters = Set.fromList $ unpack dName
|
||||
addLetters = Set.fromList [' ', ',', '.', '-']
|
||||
addLetters = Set.fromList [' ', '.', '-']
|
||||
|
||||
isAdd = (`Set.member` addLetters)
|
||||
splitAdd = Text.split isAdd
|
||||
|
||||
@ -58,7 +58,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
|
||||
let prepAddress upa = userDisplayName : (upa & html2textlines) -- TODO: use supervisor's address
|
||||
pdfMeta = mkMeta
|
||||
[ toMeta "date" letterDate
|
||||
, toMeta "lang" $ selectDeEn userLanguages -- select German or English, see Utils.Lang
|
||||
, toMeta "lang" (selectDeEn userLanguages) -- select either German or English only, see Utils.Lang
|
||||
, toMeta "login" (lmsUserIdent & getLmsIdent)
|
||||
, toMeta "pin" lmsUserPin
|
||||
, toMeta "recipient" userDisplayName
|
||||
|
||||
@ -654,6 +654,11 @@ infixl 5 !!!
|
||||
(!!!) :: (Ord k, Monoid v) => Map k v -> k -> v
|
||||
(!!!) m k = fromMaybe mempty $ Map.lookup k m
|
||||
|
||||
lookupSome :: (Monad m, Ord k, Monoid (m v)) => Map k (m v) -> m k -> m v
|
||||
-- lookupSome :: Ord k => Map k [v] -> [k] -> [v]
|
||||
-- lookupSome m ks = ks >>= (m !!!)
|
||||
lookupSome = (=<<) . (!!!)
|
||||
|
||||
groupMap :: (Ord k, Ord v) => [(k,v)] -> Map k (Set v)
|
||||
groupMap l = Map.fromListWith mappend [(k, Set.singleton v) | (k,v) <- l]
|
||||
|
||||
@ -888,7 +893,7 @@ actLeft (Left x) f = f x
|
||||
actLeft (Right y) _ = pure $ Right y
|
||||
|
||||
-- | like monadic bind for 'Either', but wrapped in another monad
|
||||
-- ok to use once, otherweise better to use 'Control.Monad.Trans.Except' instead
|
||||
-- ok to use once, otherwise better to use 'Control.Monad.Trans.Except' instead
|
||||
actRight :: Applicative f => Either a b -> (b -> f (Either a c)) -> f (Either a c)
|
||||
actRight (Left x) _ = pure $ Left x
|
||||
actRight (Right y) f = f y
|
||||
|
||||
Loading…
Reference in New Issue
Block a user