refactor(ldap login): cleanup & better error messages
This commit is contained in:
Gregor Kleen
parent
f2019a30c7
commit
e0b2f8c0c8
@ -553,6 +553,16 @@ PWHashLoginNote: Dieses Formular ist zu verwenden, wenn Sie vom Uni2work-Team sp
|
||||
DummyLoginTitle: Development-Login
|
||||
LoginNecessary: Bitte melden Sie sich dazu vorher an!
|
||||
|
||||
InternalLdapError: Interner Fehler beim Campus-Login
|
||||
|
||||
CampusUserInvalidEmail: Konnte anhand des Campus-Logins keine EMail-Addresse ermitteln
|
||||
CampusUserInvalidDisplayName: Konnte anhand des Campus-Logins keinen vollen Namen ermitteln
|
||||
CampusUserInvalidGivenName: Konnte anhand des Campus-Logins keinen Vornamen ermitteln
|
||||
CampusUserInvalidSurname: Konnte anhand des Campus-Logins keinen Nachname ermitteln
|
||||
CampusUserInvalidTitle: Konnte anhand des Campus-Logins keinen akademischen Titel ermitteln
|
||||
CampusUserInvalidMatriculation: Konnte anhand des Campus-Logins keine Matrikelnummer ermitteln
|
||||
CampusUserInvalidFeaturesOfStudy parseErr@String: Konnte anhand des Campus-Logins keine Matrikelnummer ermitteln: #{parseErr}
|
||||
|
||||
CorrectorNormal: Normal
|
||||
CorrectorMissing: Abwesend
|
||||
CorrectorExcused: Entschuldigt
|
||||
|
||||
131
src/Auth/LDAP.hs
131
src/Auth/LDAP.hs
@ -1,9 +1,12 @@
|
||||
module Auth.LDAP
|
||||
( campusLogin
|
||||
( apLdap
|
||||
, campusLogin
|
||||
, CampusUserException(..)
|
||||
, campusUser
|
||||
, CampusMessage(..)
|
||||
, Ldap.AttrList, Ldap.Attr(..), Ldap.AttrValue
|
||||
, ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
|
||||
, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname
|
||||
, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName
|
||||
) where
|
||||
|
||||
import Import.NoFoundation hiding (userEmail, userDisplayName)
|
||||
@ -42,12 +45,12 @@ findUser :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
|
||||
findUser LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase userSearchSettings) retAttrs) userFilters
|
||||
where
|
||||
userFilters =
|
||||
[ userPrincipalName Ldap.:= Text.encodeUtf8 ident
|
||||
, userPrincipalName Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
|
||||
, userEmail Ldap.:= Text.encodeUtf8 ident
|
||||
, userEmail Ldap.:= Text.encodeUtf8 [st|#{ident}@lmu.de|]
|
||||
, userEmail Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
|
||||
, userDisplayName Ldap.:= Text.encodeUtf8 ident
|
||||
[ ldapUserPrincipalName Ldap.:= Text.encodeUtf8 ident
|
||||
, ldapUserPrincipalName Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
|
||||
, ldapUserEmail Ldap.:= Text.encodeUtf8 ident
|
||||
, ldapUserEmail Ldap.:= Text.encodeUtf8 [st|#{ident}@lmu.de|]
|
||||
, ldapUserEmail Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
|
||||
, ldapUserDisplayName Ldap.:= Text.encodeUtf8 ident
|
||||
]
|
||||
userSearchSettings = mconcat
|
||||
[ Ldap.scope ldapScope
|
||||
@ -56,10 +59,53 @@ findUser LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not
|
||||
, Ldap.derefAliases Ldap.DerefAlways
|
||||
]
|
||||
|
||||
userPrincipalName, userEmail, userDisplayName :: Ldap.Attr
|
||||
userPrincipalName = Ldap.Attr "userPrincipalName"
|
||||
userEmail = Ldap.Attr "mail"
|
||||
userDisplayName = Ldap.Attr "displayName"
|
||||
ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName :: Ldap.Attr
|
||||
ldapUserPrincipalName = Ldap.Attr "userPrincipalName"
|
||||
ldapUserEmail = Ldap.Attr "mail"
|
||||
ldapUserDisplayName = Ldap.Attr "displayName"
|
||||
ldapUserMatriculation = Ldap.Attr "LMU-Stud-Matrikelnummer"
|
||||
ldapUserFirstName = Ldap.Attr "givenName"
|
||||
ldapUserSurname = Ldap.Attr "sn"
|
||||
ldapUserTitle = Ldap.Attr "title"
|
||||
ldapUserStudyFeatures = Ldap.Attr "dfnEduPersonFeaturesOfStudy"
|
||||
ldapUserFieldName = Ldap.Attr "dfnEduPersonFieldOfStudyString"
|
||||
|
||||
|
||||
data CampusUserException = CampusUserLdapError LdapPoolError
|
||||
| CampusUserHostNotResolved String
|
||||
| CampusUserLineTooLong
|
||||
| CampusUserHostCannotConnect String [IOException]
|
||||
| CampusUserNoResult
|
||||
| CampusUserAmbiguous
|
||||
deriving (Show, Eq, Generic, Typeable)
|
||||
|
||||
instance Exception CampusUserException
|
||||
|
||||
campusUser :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList [])
|
||||
campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do
|
||||
Ldap.bind ldap ldapDn ldapPassword
|
||||
results <- case lookup "DN" credsExtra of
|
||||
Just userDN -> do
|
||||
let userFilter = Ldap.Present ldapUserPrincipalName
|
||||
userSearchSettings = mconcat
|
||||
[ Ldap.scope Ldap.BaseObject
|
||||
, Ldap.size 2
|
||||
, Ldap.time ldapSearchTimeout
|
||||
, Ldap.derefAliases Ldap.DerefAlways
|
||||
]
|
||||
Ldap.search ldap (Ldap.Dn userDN) userSearchSettings userFilter []
|
||||
Nothing -> do
|
||||
findUser conf ldap credsIdent []
|
||||
case results of
|
||||
[] -> throwM CampusUserNoResult
|
||||
[Ldap.SearchEntry _ attrs] -> return attrs
|
||||
_otherwise -> throwM CampusUserAmbiguous
|
||||
where
|
||||
errHandlers = [ Exc.Handler $ \LineTooLong -> throwM CampusUserLineTooLong
|
||||
, Exc.Handler $ \(HostNotResolved host) -> throwM $ CampusUserHostNotResolved host
|
||||
, Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs
|
||||
]
|
||||
|
||||
|
||||
campusForm :: ( RenderMessage site FormMessage
|
||||
, RenderMessage site CampusMessage
|
||||
@ -69,6 +115,9 @@ campusForm = CampusLogin
|
||||
<$> areq ciField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote & addAttr "autofocus" "") Nothing
|
||||
<*> areq passwordField (fslI MsgCampusPassword) Nothing
|
||||
|
||||
apLdap :: Text
|
||||
apLdap = "LDAP"
|
||||
|
||||
campusLogin :: forall site.
|
||||
( YesodAuth site
|
||||
, RenderMessage site FormMessage
|
||||
@ -78,7 +127,7 @@ campusLogin :: forall site.
|
||||
) => LdapConf -> LdapPool -> AuthPlugin site
|
||||
campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
|
||||
where
|
||||
apName = "LDAP"
|
||||
apName = apLdap
|
||||
apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
|
||||
apDispatch "POST" [] = do
|
||||
((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard campusForm
|
||||
@ -90,10 +139,10 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
|
||||
FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do
|
||||
ldapResult <- withLdap pool $ \ldap -> do
|
||||
Ldap.bind ldap ldapDn ldapPassword
|
||||
searchResults <- findUser conf ldap campusIdent [userPrincipalName]
|
||||
searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName]
|
||||
case searchResults of
|
||||
[Ldap.SearchEntry (Ldap.Dn userDN) userAttrs]
|
||||
| Just [principalName] <- lookup userPrincipalName userAttrs
|
||||
| [principalName] <- fold [ v | (k, v) <- userAttrs, k == ldapUserPrincipalName ]
|
||||
, Right credsIdent <- Text.decodeUtf8' principalName
|
||||
-> Right (userDN, credsIdent) <$ Ldap.bind ldap (Ldap.Dn credsIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword)
|
||||
other -> return $ Left other
|
||||
@ -123,55 +172,3 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
|
||||
, formAnchor = Just "login--campus" :: Maybe Text
|
||||
}
|
||||
$(widgetFile "widgets/campus-login/campus-login-form")
|
||||
|
||||
data CampusUserException = CampusUserLdapError LdapPoolError
|
||||
| CampusUserHostNotResolved String
|
||||
| CampusUserLineTooLong
|
||||
| CampusUserHostCannotConnect String [IOException]
|
||||
| CampusUserNoResult
|
||||
| CampusUserAmbiguous
|
||||
deriving (Show, Eq, Generic, Typeable)
|
||||
|
||||
instance Exception CampusUserException
|
||||
|
||||
campusUser :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList [])
|
||||
campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do
|
||||
Ldap.bind ldap ldapDn ldapPassword
|
||||
results <- case lookup "DN" credsExtra of
|
||||
Just userDN -> do
|
||||
let userFilter = Ldap.Present userPrincipalName
|
||||
userSearchSettings = mconcat
|
||||
[ Ldap.scope Ldap.BaseObject
|
||||
, Ldap.size 2
|
||||
, Ldap.time ldapSearchTimeout
|
||||
, Ldap.derefAliases Ldap.DerefAlways
|
||||
]
|
||||
Ldap.search ldap (Ldap.Dn userDN) userSearchSettings userFilter []
|
||||
Nothing -> do
|
||||
findUser conf ldap credsIdent []
|
||||
case results of
|
||||
[] -> throwM CampusUserNoResult
|
||||
[Ldap.SearchEntry _ attrs] -> return attrs
|
||||
_otherwise -> throwM CampusUserAmbiguous
|
||||
where
|
||||
errHandlers = [ Exc.Handler $ \LineTooLong -> throwM CampusUserLineTooLong
|
||||
, Exc.Handler $ \(HostNotResolved host) -> throwM $ CampusUserHostNotResolved host
|
||||
, Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs
|
||||
]
|
||||
|
||||
-- ldapConfig :: UniWorX -> LDAPConfig
|
||||
-- ldapConfig _app@(appSettings' -> settings) = LDAPConfig
|
||||
-- { usernameFilter = \u -> principalName <> "=" <> u
|
||||
-- , identifierModifier
|
||||
-- , ldapUri = appLDAPURI settings
|
||||
-- , initDN = appLDAPDN settings
|
||||
-- , initPass = appLDAPPw settings
|
||||
-- , baseDN = appLDAPBaseName settings
|
||||
-- , ldapScope = LdapScopeSubtree
|
||||
-- }
|
||||
-- where
|
||||
-- principalName :: IsString a => a
|
||||
-- principalName = "userPrincipalName"
|
||||
-- identifierModifier _ entry = case lookup principalName $ leattrs entry of
|
||||
-- Just [n] -> Text.pack n
|
||||
-- _ -> error "Could not determine user principal name"
|
||||
|
||||
@ -55,7 +55,7 @@ import Data.Conduit.List (sourceList)
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Control.Monad.Except (MonadError(..), ExceptT, runExceptT)
|
||||
import Control.Monad.Except (MonadError(..), ExceptT)
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
import Control.Monad.Trans.Reader (runReader, mapReaderT)
|
||||
import Control.Monad.Trans.Writer (WriterT(..), runWriterT)
|
||||
@ -88,6 +88,8 @@ import qualified Data.Aeson as JSON
|
||||
|
||||
import Data.FileEmbed (embedFile)
|
||||
|
||||
import qualified Ldap.Client as Ldap
|
||||
|
||||
|
||||
type SMTPPool = Pool SMTPConnection
|
||||
|
||||
@ -2732,6 +2734,155 @@ instance YesodPersist UniWorX where
|
||||
instance YesodPersistRunner UniWorX where
|
||||
getDBRunner = defaultGetDBRunner appConnPool
|
||||
|
||||
data CampusUserConversionException
|
||||
= CampusUserInvalidEmail
|
||||
| CampusUserInvalidDisplayName
|
||||
| CampusUserInvalidGivenName
|
||||
| CampusUserInvalidSurname
|
||||
| CampusUserInvalidTitle
|
||||
| CampusUserInvalidMatriculation
|
||||
| CampusUserInvalidFeaturesOfStudy String
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
instance Exception CampusUserConversionException
|
||||
|
||||
embedRenderMessage ''UniWorX ''CampusUserConversionException id
|
||||
|
||||
upsertCampusUser :: Ldap.AttrList [] -> Creds UniWorX -> DB (Entity User)
|
||||
upsertCampusUser ldapData Creds{..} = do
|
||||
now <- liftIO getCurrentTime
|
||||
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
|
||||
|
||||
let
|
||||
userMatrikelnummer' = fold [ v | (k, v) <- ldapData, k == ldapUserMatriculation ]
|
||||
userEmail' = fold [ v | (k, v) <- ldapData, k == ldapUserEmail ]
|
||||
userDisplayName' = fold [ v | (k, v) <- ldapData, k == ldapUserDisplayName ]
|
||||
userFirstName' = fold [ v | (k, v) <- ldapData, k == ldapUserFirstName ]
|
||||
userSurname' = fold [ v | (k, v) <- ldapData, k == ldapUserSurname ]
|
||||
userTitle' = fold [ v | (k, v) <- ldapData, k == ldapUserTitle ]
|
||||
|
||||
userAuthentication
|
||||
| isPWHash = error "PWHash should only work for users that are already known"
|
||||
| otherwise = AuthLDAP
|
||||
userLastAuthentication = now <$ guard (not isDummy)
|
||||
|
||||
userEmail <- if
|
||||
| [bs] <- userEmail'
|
||||
, Right userEmail <- Text.decodeUtf8' bs
|
||||
-> return $ 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
|
||||
userSurname <- if
|
||||
| [bs] <- userSurname'
|
||||
, Right userSurname <- Text.decodeUtf8' bs
|
||||
-> return userSurname
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidSurname
|
||||
userTitle <- if
|
||||
| all ByteString.null userTitle'
|
||||
-> return Nothing
|
||||
| [bs] <- userTitle'
|
||||
, Right userTitle <- Text.decodeUtf8' bs
|
||||
-> return $ Just userTitle
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidTitle
|
||||
userMatrikelnummer <- if
|
||||
| [bs] <- userMatrikelnummer'
|
||||
, Right userMatrikelnummer <- Text.decodeUtf8' bs
|
||||
-> return $ Just userMatrikelnummer
|
||||
| [] <- userMatrikelnummer'
|
||||
-> return Nothing
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidMatriculation
|
||||
|
||||
let
|
||||
newUser = User
|
||||
{ userIdent = mk credsIdent
|
||||
, userMaxFavourites = userDefaultMaxFavourites
|
||||
, userTheme = userDefaultTheme
|
||||
, userDateTimeFormat = userDefaultDateTimeFormat
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
, userNotificationSettings = def
|
||||
, userMailLanguages = def
|
||||
, userTokensIssuedAfter = Nothing
|
||||
, ..
|
||||
}
|
||||
userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
|
||||
, UserDisplayName =. userDisplayName
|
||||
, UserSurname =. userSurname
|
||||
, UserEmail =. userEmail
|
||||
] ++
|
||||
[ UserLastAuthentication =. Just now | not isDummy ]
|
||||
|
||||
user@(Entity userId _) <- upsertBy (UniqueAuthentication $ mk credsIdent) newUser userUpdate
|
||||
|
||||
let
|
||||
userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now
|
||||
userStudyFeatures' = do
|
||||
(k, v) <- ldapData
|
||||
guard $ k == ldapUserStudyFeatures
|
||||
v' <- v
|
||||
Right str <- return $ Text.decodeUtf8' v'
|
||||
return str
|
||||
|
||||
termNames = nubBy ((==) `on` mk) $ do
|
||||
(k, v) <- ldapData
|
||||
guard $ k == ldapUserFieldName
|
||||
v' <- v
|
||||
Right str <- return $ Text.decodeUtf8' v'
|
||||
return str
|
||||
|
||||
fs <- either (throwM . CampusUserInvalidFeaturesOfStudy . unpack) return userStudyFeatures
|
||||
|
||||
let
|
||||
studyTermCandidates = Set.fromList $ do
|
||||
name <- termNames
|
||||
StudyFeatures{ studyFeaturesField = StudyTermsKey' key } <- fs
|
||||
return (key, name)
|
||||
studyTermCandidateIncidence
|
||||
= fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID") -- Should never happen
|
||||
. UUID.fromByteString
|
||||
. fromStrict
|
||||
. (convert :: Digest (SHAKE128 128) -> ByteString)
|
||||
. runIdentity
|
||||
$ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) $$ sinkHash
|
||||
|
||||
[E.Value candidatesRecorded] <- E.select . return . E.exists . E.from $ \candidate ->
|
||||
E.where_ $ candidate E.^. StudyTermCandidateIncidence E.==. E.val studyTermCandidateIncidence
|
||||
|
||||
unless candidatesRecorded $ do
|
||||
let
|
||||
studyTermCandidates' = do
|
||||
(studyTermCandidateKey, studyTermCandidateName) <- Set.toList studyTermCandidates
|
||||
return StudyTermCandidate{..}
|
||||
insertMany_ studyTermCandidates'
|
||||
|
||||
E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False]
|
||||
forM_ fs $ \f@StudyFeatures{..} -> do
|
||||
insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
|
||||
insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing
|
||||
void $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True]
|
||||
|
||||
return user
|
||||
where
|
||||
insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
|
||||
isDummy = credsPlugin == "dummy"
|
||||
isPWHash = credsPlugin == "PWHash"
|
||||
|
||||
|
||||
instance YesodAuth UniWorX where
|
||||
type AuthId UniWorX = UserId
|
||||
|
||||
@ -2761,25 +2912,34 @@ instance YesodAuth UniWorX where
|
||||
isDummy = credsPlugin == "dummy"
|
||||
isPWHash = credsPlugin == "PWHash"
|
||||
|
||||
excHandlers
|
||||
excRecovery res
|
||||
| isDummy || isPWHash
|
||||
= [ C.Handler $ \err -> do
|
||||
addMessage Error (toHtml $ tshow (err :: CampusUserException))
|
||||
$logErrorS "LDAP" $ tshow err
|
||||
acceptExisting
|
||||
]
|
||||
= do
|
||||
case res of
|
||||
UserError err -> addMessageI Error err
|
||||
ServerError err -> addMessage Error $ toHtml err
|
||||
_other -> return ()
|
||||
acceptExisting
|
||||
| otherwise
|
||||
= [ C.Handler $ \case
|
||||
CampusUserNoResult -> do
|
||||
$logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent
|
||||
return . UserError $ IdentifierNotFound credsIdent
|
||||
CampusUserAmbiguous -> do
|
||||
$logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent
|
||||
return . UserError $ IdentifierNotFound credsIdent
|
||||
err -> do
|
||||
$logErrorS "LDAP" $ tshow err
|
||||
return $ ServerError "LDAP lookup failed"
|
||||
]
|
||||
= return res
|
||||
|
||||
excHandlers =
|
||||
[ C.Handler $ \case
|
||||
CampusUserNoResult -> do
|
||||
$logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent
|
||||
excRecovery . UserError $ IdentifierNotFound credsIdent
|
||||
CampusUserAmbiguous -> do
|
||||
$logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent
|
||||
excRecovery . UserError $ IdentifierNotFound credsIdent
|
||||
err -> do
|
||||
$logErrorS "LDAP" $ tshow err
|
||||
mr <- getMessageRender
|
||||
excRecovery . ServerError $ mr MsgInternalLdapError
|
||||
, C.Handler $ \(cExc :: CampusUserConversionException) -> do
|
||||
$logErrorS "LDAP" $ tshow cExc
|
||||
mr <- getMessageRender
|
||||
excRecovery . ServerError $ mr cExc
|
||||
]
|
||||
|
||||
acceptExisting = do
|
||||
res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
|
||||
@ -2792,138 +2952,13 @@ instance YesodAuth UniWorX where
|
||||
UniWorX{ appSettings' = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod
|
||||
|
||||
flip catches excHandlers $ case (,) <$> appLdapConf <*> appLdapPool of
|
||||
Just (ldapConf, ldapPool) -> fmap (either id id) . runExceptT $ do
|
||||
ldapData <- campusUser ldapConf ldapPool $ Creds credsPlugin (original userIdent) credsExtra
|
||||
Just (ldapConf, ldapPool) -> do
|
||||
let userCreds = Creds credsPlugin (original userIdent) credsExtra
|
||||
ldapData <- campusUser ldapConf ldapPool userCreds
|
||||
$logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
|
||||
|
||||
let
|
||||
userMatrikelnummer' = lookup (Attr "LMU-Stud-Matrikelnummer") ldapData
|
||||
userEmail' = lookup (Attr "mail") ldapData
|
||||
userDisplayName' = lookup (Attr "displayName") ldapData
|
||||
userFirstName' = lookup (Attr "givenName") ldapData
|
||||
userSurname' = lookup (Attr "sn") ldapData
|
||||
userTitle' = lookup (Attr "title") ldapData
|
||||
|
||||
userAuthentication
|
||||
| isPWHash = error "PWHash should only work for users that are already known"
|
||||
| otherwise = AuthLDAP
|
||||
userLastAuthentication = now <$ guard (not isDummy)
|
||||
|
||||
userEmail <- if
|
||||
| Just [bs] <- userEmail'
|
||||
, Right userEmail <- Text.decodeUtf8' bs
|
||||
-> return $ mk userEmail
|
||||
| otherwise
|
||||
-> throwError $ ServerError "Could not retrieve user email"
|
||||
userDisplayName <- if
|
||||
| Just [bs] <- userDisplayName'
|
||||
, Right userDisplayName <- Text.decodeUtf8' bs
|
||||
-> return userDisplayName
|
||||
| otherwise
|
||||
-> throwError $ ServerError "Could not retrieve user name"
|
||||
userFirstName <- if
|
||||
| Just [bs] <- userFirstName'
|
||||
, Right userFirstName <- Text.decodeUtf8' bs
|
||||
-> return userFirstName
|
||||
| otherwise
|
||||
-> throwError $ ServerError "Could not retrieve user given name"
|
||||
userSurname <- if
|
||||
| Just [bs] <- userSurname'
|
||||
, Right userSurname <- Text.decodeUtf8' bs
|
||||
-> return userSurname
|
||||
| otherwise
|
||||
-> throwError $ ServerError "Could not retrieve user surname"
|
||||
userTitle <- if
|
||||
| maybe True (all ByteString.null) userTitle'
|
||||
-> return Nothing
|
||||
| Just [bs] <- userTitle'
|
||||
, Right userTitle <- Text.decodeUtf8' bs
|
||||
-> return $ Just userTitle
|
||||
| otherwise
|
||||
-> throwError $ ServerError "Could not retrieve user title"
|
||||
userMatrikelnummer <- if
|
||||
| Just [bs] <- userMatrikelnummer'
|
||||
, Right userMatrikelnummer <- Text.decodeUtf8' bs
|
||||
-> return $ Just userMatrikelnummer
|
||||
| Nothing <- userMatrikelnummer'
|
||||
-> return Nothing
|
||||
| otherwise
|
||||
-> throwError $ ServerError "Could not decode user matriculation"
|
||||
|
||||
let
|
||||
newUser = User
|
||||
{ userMaxFavourites = userDefaultMaxFavourites
|
||||
, userTheme = userDefaultTheme
|
||||
, userDateTimeFormat = userDefaultDateTimeFormat
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
, userDownloadFiles = userDefaultDownloadFiles
|
||||
, userNotificationSettings = def
|
||||
, userMailLanguages = def
|
||||
, userTokensIssuedAfter = Nothing
|
||||
, ..
|
||||
}
|
||||
userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
|
||||
, UserDisplayName =. userDisplayName
|
||||
, UserSurname =. userSurname
|
||||
, UserEmail =. userEmail
|
||||
] ++
|
||||
[ UserLastAuthentication =. Just now | not isDummy ]
|
||||
|
||||
userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate
|
||||
|
||||
let
|
||||
userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now
|
||||
userStudyFeatures' = do
|
||||
(k, v) <- ldapData
|
||||
guard $ k == Attr "dfnEduPersonFeaturesOfStudy"
|
||||
v' <- v
|
||||
Right str <- return $ Text.decodeUtf8' v'
|
||||
return str
|
||||
|
||||
termNames = nubBy ((==) `on` mk) $ do
|
||||
(k, v) <- ldapData
|
||||
guard $ k == Attr "dfnEduPersonFieldOfStudyString"
|
||||
v' <- v
|
||||
Right str <- return $ Text.decodeUtf8' v'
|
||||
return str
|
||||
|
||||
fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures
|
||||
|
||||
let
|
||||
studyTermCandidates = Set.fromList $ do
|
||||
name <- termNames
|
||||
StudyFeatures{ studyFeaturesField = StudyTermsKey' key } <- fs
|
||||
return (key, name)
|
||||
studyTermCandidateIncidence
|
||||
= fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID")
|
||||
. UUID.fromByteString
|
||||
. fromStrict
|
||||
. (convert :: Digest (SHAKE128 128) -> ByteString)
|
||||
. runIdentity
|
||||
$ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) $$ sinkHash
|
||||
|
||||
[E.Value candidatesRecorded] <- lift . E.select . return . E.exists . E.from $ \candidate ->
|
||||
E.where_ $ candidate E.^. StudyTermCandidateIncidence E.==. E.val studyTermCandidateIncidence
|
||||
|
||||
unless candidatesRecorded $ do
|
||||
let
|
||||
studyTermCandidates' = do
|
||||
(studyTermCandidateKey, studyTermCandidateName) <- Set.toList studyTermCandidates
|
||||
return StudyTermCandidate{..}
|
||||
lift $ insertMany_ studyTermCandidates'
|
||||
|
||||
lift $ E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False]
|
||||
forM_ fs $ \f@StudyFeatures{..} -> do
|
||||
lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
|
||||
lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing
|
||||
void . lift $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True]
|
||||
|
||||
return $ Authenticated userId
|
||||
Nothing -> acceptExisting
|
||||
|
||||
where
|
||||
insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
|
||||
Authenticated . entityKey <$> upsertCampusUser ldapData userCreds
|
||||
Nothing
|
||||
-> acceptExisting
|
||||
|
||||
authPlugins (UniWorX{ appSettings' = AppSettings{..}, appLdapPool }) = catMaybes
|
||||
[ campusLogin <$> appLdapConf <*> appLdapPool
|
||||
|
||||
@ -260,10 +260,7 @@ postAdminUserR uuid = do
|
||||
campusHandler _ = mzero
|
||||
campusResult <- runMaybeT . handle campusHandler $ do
|
||||
(Just pool, Just conf) <- getsYesod $ (,) <$> view _appLdapPool <*> view _appLdapConf
|
||||
let
|
||||
campusLogin :: AuthPlugin UniWorX
|
||||
campusLogin = Auth.campusLogin conf pool
|
||||
void . Auth.campusUser conf pool $ Creds (apName campusLogin) (CI.original userIdent) []
|
||||
void . Auth.campusUser conf pool $ Creds Auth.apLdap (CI.original userIdent) []
|
||||
case campusResult of
|
||||
Nothing -> addMessageI Error MsgAuthLDAPInvalidLookup
|
||||
_other
|
||||
|
||||
Loading…
Reference in New Issue
Block a user